学步园

VB6的三层架构的相关资料在网络上只有很少的资料,流传开来的我知道的只有两种模式:

1.集合模式:该模式在广为流传,但是效率很差且并也没有DataAccess层,BusinessRule和DataAccess混在一起.

2.Type数组模式:效较较集合有所提升,但是灵活性较差,字段没有Null状态,且由于Type数组是值类型,实际调用时有可能放于栈空间,如果Type数组过大可能溢出.

经过分析.Net中的MS的例子,我考虑将.Net中的使用 ADO.Net实现的三层架构拿到VB6上来运行,ADO.Net使用ADO的Recordset来代替.由于ADO.Net先天的优越性,使用 RecordSet遇到了好多问题,即使到现在依然有一些问题的存在,且于由RecordSet的先天不足而使其实现的方式很别扭,但是总算是模拟了三层架构.

下面简单的给出三层架构的部分源码以供分析：

一、DataAccess层：

 mdlDAErrorConst模块：

Public Const PROBEGINNUMBER = vbObjectError + 10000
'**************************************程序编写错误****************************************
Public Const OBJECTTYPEERROR = PROBEGINNUMBER                               '对象类型错误
Public Const OBJECTTYPEERRORDESCRIPTION = "对象类型错误"

Public Const RECORDCOUNTISZERO = PROBEGINNUMBER + 1                         '记录集记录数
Public Const RECORDCOUNTISZERODESCRIPTION = "对象数集记录数为0"

Public Const PARAMETERCOUNTERROR = PROBEGINNUMBER + 2                       '参数错误
Public Const PARAMETERCOUNTERRORDESCRIPTION = "传递的参数错误"

Public Const NOKEYFIELD = PROBEGINNUMBER + 3
Public Const NOKEYFIELDDESCRIPTION = "对象没有设置关键字段列表"

Public Const KEYFIELDNOVALUE = PROBEGINNUMBER + 4
Public Const KEYFIELDNOVALUEDESCRIPTION = "对关键字段没有设定值"

mdlGlobal模块：

Option Explicit

'***********************************************全局变量***************************************
'全局的数据库连接
Public objDatabase As clsDatabase

'***********************************************全局常量***************************************
Public Const DATAERROR = "数据库操作发生错误:"
'********************************************行状态枚举*********************************
Public Enum DataRowState
    Added = 1
    Deleted = 2
    Modified = 3
    Unchanged = 4
End Enum
'***********************************************全局函数***************************************
'判断是否为空值或未设过值
Public Function CheckIsNull(vValue As Variant) As Boolean
    If IsNull(vValue) Or IsEmpty(vValue) Then
        CheckIsNull = True
    Else
        CheckIsNull = False
    End If
End Function

'返回指定的ICommon接口的所有可用的数据库字段,用逗号分隔
Public Function GetFieldNames(objCommon As prjCommon.ICommon) As String
    Dim vData As Variant
    Dim str As String
    Dim i As Integer
    vData = objCommon.GetFieldNames
    For i = LBound(vData) To UBound(vData)
        If str = "" Then
            str = CStr(vData(i))
        Else
            str = str & "," & CStr(vData(i))
        End If
    Next
    GetFieldNames = str
End Function

'返回指定的ICommonDesc接口的所有可用的数据库字段,用逗号分隔
Public Function GetFieldNamesForDesc(objCommon As prjCommon.ICommonDesc) As String
    Dim vData As Variant
    Dim str As String
    Dim i As Integer
    vData = objCommon.GetFieldNames
    For i = LBound(vData) To UBound(vData)
        If str = "" Then
            str = CStr(vData(i))
        Else
            str = str & "," & CStr(vData(i))
        End If
    Next
    GetFieldNamesForDesc = str
End Function
'得到字段的真实值,如果未赋值返回为"NULL"
'得到字段的值
Public Function GetFieldValue(objField As ADODB.Field) As String
    With objField
        If .Type = adBigInt _
                Or .Type = adBoolean _
                Or .Type = adCurrency _
                Or .Type = adDecimal _
                Or .Type = adDouble _
                Or .Type = adInteger _
                Or .Type = adNumeric _
                Or .Type = adSingle _
                Or .Type = adSmallInt _
                Or .Type = adTinyInt Then
            If CheckIsNull(objField.Value) = False Then
                GetFieldValue = CStr(CDbl(objField.Value))
            Else
                GetFieldValue = "NULL"
            End If
        Else
            If CheckIsNull(objField.Value) = False Then
                GetFieldValue = "'" & CStr(objField.Value) & "'"
            Else
                GetFieldValue = "NULL"
            End If
        End If
    End With
End Function
'得到关于Desc内部的Rst使用的字段名
'str处理方式:(1)有" AS "的取后面的为字段名
'           (2)有小数量的,则取小数点后
Public Function GetInsideFieldName(str As Variant) As String
    Dim i As Integer, stmp As String, b() As String
    str = CStr(str)
    i = InStr(1, LCase(str), LCase(" AS "), vbTextCompare)
    If i <> 0 Then
        stmp = Right(str, Len(str) - i - Len(" AS ") + 1)
    Else
        b = Split(str, ".")
        If UBound(b) = 1 Then
            stmp = b(1)
        Else
            stmp = vbNullString
        End If
    End If
    GetInsideFieldName = stmp
End Function

clsDAOperator类，实现增、删、改功能：

Option Explicit
Private mRst As ADODB.Recordset
Private strSQL As String
Private objMakeSQL As clsSQLMaker

'初始化
Private Sub Class_Initialize()
    Set objMakeSQL = New clsSQLMaker
End Sub
'删除A
Public Function DeleteByCommon(objCommon As prjCommon.ICommon) As Integer
    On Error GoTo errHandle:
    strSQL = objMakeSQL.GetDeleteSqlByCommon(objCommon)
    DeleteByCommon = objDatabase.ExecuteNonRst(strSQL)
    Exit Function
errHandle:
    Err.Raise Err.Number, Err.Source, DATAERROR & Err.Description
End Function
'删除B
Public Function DeleteByCondition(objCommon As prjCommon.ICommon, _
                                            cstrWhere As String) As Integer
    On Error GoTo errHandle:
    strSQL = objMakeSQL.GetDeleteSqlByCommon(objCommon)
    If CStr(cstrWhere) <> "" Then
        strSQL = strSQL & " WHERE " & cstrWhere
    End If
    DeleteByCondition = objDatabase.ExecuteNonRst(strSQL)
    Exit Function
errHandle:
    Err.Raise Err.Number, Err.Source, DATAERROR & Err.Description
End Function
'查找A
Public Function FindByCommon(retCommon As prjCommon.ICommon, ConditionCommon As prjCommon.ICommon) As Boolean
    Dim vFields As Variant, i As Integer
    On Error GoTo errHandle:
    If TypeName(retCommon) <> TypeName(ConditionCommon) Then
        Err.Raise OBJECTTYPEERROR, TypeName(Me), OBJECTTYPEERRORDESCRIPTION
    End If
    strSQL = objMakeSQL.GetSelectSqlWithWhere(ConditionCommon)
    Set retCommon.Data = objDatabase.ExecuteRst(strSQL)
    FindByCommon = True
    Exit Function
errHandle:
    Err.Raise Err.Number, Err.Source, Err.Description
End Function
'查找B
Public Function FindByCondition(retCommon As prjCommon.ICommon, cstrWhere As String) As Boolean
    Dim vFields As Variant, i As Integer
    On Error GoTo errHandle:
    strSQL = objMakeSQL.GetSelectSQL(retCommon)
    If Trim(cstrWhere) <> "" Then
        strSQL = strSQL & " WHERE " & cstrWhere
    End If
    Set retCommon.Data = objDatabase.ExecuteRst(strSQL)
    FindByCondition = True
    Exit Function
errHandle:
    Err.Raise Err.Number, Err.Source, Err.Description
End Function

'插入
Public Function Insert(objCommon As prjCommon.ICommon) As Boolean
    On Error GoTo errHandle:
    Dim vFields As Variant, i As Integer, vKeyFields As Variant
    '取得字段列表
    vFields = objCommon.GetFieldNames
    vKeyFields = objCommon.GetKeyFields
    strSQL = objMakeSQL.GetSelectTop1SQL(objCommon)
    Set mRst = objDatabase.ExecuteRst(strSQL)
    mRst.AddNew
    For i = LBound(vFields) To UBound(vFields)
        '如果非空的话才赋值,否则会出错
        If CheckIsNull(objCommon.Data.Fields(vFields(i))) = False Then
            mRst.Fields(vFields(i)).Value = objCommon.Data.Fields(vFields(i)).Value
        Else
            Debug.Print vFields(i)
        End If
    Next
    mRst.Update
    '更新主关键字
    For i = LBound(vKeyFields) To UBound(vKeyFields)
        objCommon.Data.Fields(vKeyFields(i)).Value = mRst.Fields(vKeyFields(i)).Value
    Next
    Insert = True
    Exit Function
errHandle:
    Err.Raise Err.Number, TypeName(Me), DATAERROR & Err.Description
End Function
'更新A
Public Function UpdateByCondition(objCommon As prjCommon.ICommon, cstrWhere As String) As Integer
    On Error GoTo errHandle:
    strSQL = objMakeSQL.GetUpdateSqlByStrWhere(objCommon, cstrWhere)
    UpdateByCondition = objDatabase.ExecuteNonRst(strSQL)
    Exit Function
errHandle:
    Err.Raise Err.Number, Err.Source, Err.Description
End Function
'更新B
Public Function UpdateByConditionCommon(objCommon As prjCommon.ICommon, ConditionCommon As prjCommon.ICommon) As Integer
    On Error GoTo errHandle:
    If ConditionCommon.Data.RecordCount < 1 Then
        Err.Raise RECORDCOUNTISZERO, TypeName(Me), RECORDCOUNTISZERODESCRIPTION
    End If
    strSQL = objMakeSQL.GetUpdateSqlByCommon(objCommon, ConditionCommon)
    UpdateByConditionCommon = objDatabase.ExecuteNonRst(strSQL)
    Exit Function
errHandle:
    Err.Raise Err.Number, Err.Source, Err.Description
End Function
'更新C-查找objCommon的关键字段,然后更新
Public Function UpdateBySingleCommon(objCommon As prjCommon.ICommon) As Integer
    On Error GoTo errHandle:
    strSQL = objMakeSQL.GetUpdateSqlBySingleCommon(objCommon)
    UpdateBySingleCommon = objDatabase.ExecuteNonRst(strSQL)
    Exit Function
errHandle:
    Err.Raise Err.Number, Err.Source, Err.Description
End Function

Private Sub Class_Terminate()
    Set mRst = Nothing
    Set objMakeSQL = Nothing
End Sub

clsDataAccess类，对ADO的包装，实现对数据的实际操作调用：

'*************************************************************************
'**模 块 名：clsDatabase
'**说    明： 版权所有2005 - 2006(C)
'**创 建 人：吴东雷
'**日    期：2005-10-27
'**修 改 人：
'**日    期：
'**描    述：数据库组件
'**版    本：V1.0.0
'*************************************************************************
Option Explicit

Private cstrSql As String
Private cRst As ADODB.Recordset
Public Conn As ADODB.Connection
Public cCmd As ADODB.Command
Private cPara As ADODB.Parameter
Private boolTrans As Integer            '记录当前对象是否已经开始了事务
Private cConnectionString As String

Public Property Get ConnectionString() As String
    ConnectionString = Conn.ConnectionString
End Property
Public Property Let ConnectionString(vData As String)
    On Error GoTo errHandle:
    Call cSwitchCnn(Conn, False)
    Conn.ConnectionString = vData
    Call cSwitchCnn(Conn, True)
    Exit Property
errHandle:
    Err.Raise Err.Number, Err.Source, Err.Description
End Property

Private Sub Class_Initialize()
    Set cRst = New ADODB.Recordset
    Set Conn = New ADODB.Connection
    Set cCmd = New ADODB.Command
    Conn.CursorLocation = adUseClient
    'cCmd.ActiveConnection = Conn
    boolTrans = False
End Sub
Private Sub Class_Terminate()
    Set cRst = Nothing
    If Conn.State = adStateOpen Then
        Me.RollBackTransaction
        Conn.Close
    End If
    Set cCmd = Nothing
    Set Conn = Nothing
End Sub
'打开/关闭连接
Private Sub cSwitchCnn(Cnn As ADODB.Connection, _
                        OnOff As Boolean)
    On Error GoTo errHandle:
    If OnOff = True Then
        If Cnn.State <> adStateOpen Then
            Call Cnn.Open
        End If
    Else
        If Cnn.State <> adStateClosed Then
            Call Cnn.Close
        End If
    End If
    Exit Sub
errHandle:
    Err.Raise Err.Number, Err.Source, Err.Description
End Sub
''-------------------------用于主从表的事务处理--------------------
Public Sub BeginTransaction()
    If boolTrans < 0