crecord.cls

数据库连接封装控件 可以连接Access

        Resume ErrOut
    End If

ExitEntry:
    Move = True
    mstrErrDescription = ""
    mlngErrNo = 0
    Exit Function

ErrOut:
    Move = False
    mlngErrNo = -1
    mstrErrDescription = "目前记录为空，无法移动！"
    Exit Function
OutSpace:
    Move = False
    mlngErrNo = -1
    mstrErrDescription = "移动越界。"
    Exit Function
E:
    Move = False
    mlngErrNo = Err.Number
    mstrErrDescription = Err.Description

End Function

'******************************************************************************
'目的：移动到最后一条记录
'输入：
'返回：成功/失败
'******************************************************************************

Public Function MoveLast()
  On Error GoTo E
    If Not IsArray(mvarData) Then Resume ErrOut
    If UBound(mvarData) >= 0 Then
        mCurPosition = UBound(mvarData)
    Else
        Resume ErrOut
    End If
ExitEntry:
    MoveLast = True
    mstrErrDescription = ""
    mlngErrNo = 0
    Exit Function
ErrOut:
    mlngErrNo = -1
    mstrErrDescription = "目前记录为空，无法移动！"
    Exit Function
E:
    MoveLast = False
    mlngErrNo = Err.Number
    mstrErrDescription = Err.Description
End Function

'******************************************************************************
'目的：根据FieldName找对应Item
'输入：FeildName
'返回：Item
'******************************************************************************

Private Function Name2Item(ByVal sName As String) As Long
    On Error GoTo ErrH
    Dim i As Long
    
    Name2Item = -1
    If Not IsArray(mstrField) Then
        Exit Function
    Else
        For i = 0 To UBound(mstrField)
            If UCase(sName) = UCase(mstrField(i)) Then
                Name2Item = i
                Exit Function
            End If
        Next i
    End If
    
    Exit Function
ErrH:
    
End Function

'******************************************************************************
'目的：   根据Item找FieldName
'输入：   Item
'返回：   FieldName
'******************************************************************************

Private Function Item2Name(ByVal Item As Long) As String
    On Error Resume Next
    
    Item2Name = ""
    If Not IsArray(mstrField) Then
        Exit Function
    ElseIf UBound(mstrField) <= Item Then
        Item2Name = mstrField(Item)
        Exit Function
    End If
End Function


'******************************************************************************
'目的：    检查输入的FieldName是否合法
'输入：    FieldName
'返回：    True/False
'******************************************************************************

Private Function CheckField(ByVal sName As String) As Boolean
    On Error GoTo ErrH
    Dim i As Long
    
    CheckField = False
    If Not IsArray(mstrField) Then
        Exit Function
    End If
    
    For i = 0 To UBound(mstrField)
        If UCase(mstrField(i)) = UCase(sName) Then
            CheckField = True
            Exit Function
        End If
    Next i
    
    Exit Function
ErrH:
    
End Function

Public Property Let TableName(ByVal sTableName As String)
    mstrTableName = sTableName
End Property
Public Property Get TableName() As String
    TableName = mstrTableName
End Property

Public Function AddKeyField(ByVal Field As Variant) As Boolean
    On Error GoTo E
    Dim i As Integer, varTemp As Variant
    Dim sFieldName As String, lngItem As Long
    
    If Not IsArray(mstrField) Then
        mlngErrNo = -1
        mstrErrDescription = "请先使用AddField添加两个或两个以上字段。"
        Exit Function
    End If
    If Not IsNumeric(Field) Then
        If CheckField(Field) Then
            sFieldName = Field
        End If
    Else
        sFieldName = Item2Name(Val(Field))
    End If
    
    If sFieldName <> "" Then
        If IsArray(mstrKeyField) Then
            ReDim Preserve mstrKeyField(UBound(mstrKeyField) + 1) As Variant
            mstrKeyField(UBound(mstrKeyField)) = sFieldName
        Else
            ReDim mstrKeyField(0) As Variant
            mstrKeyField(0) = sFieldName
        End If
    Else
        Resume InvalidField
    End If
        
ExitEntry:
    AddKeyField = True
    mstrErrDescription = ""
    mlngErrNo = 0
    Exit Function
InvalidField:
    AddKeyField = False
    mstrErrDescription = "无效的字段。"
    mlngErrNo = -1
    Exit Function
E:
    AddKeyField = False
    mlngErrNo = Err.Number
    mstrErrDescription = Err.Description
End Function

Public Function Save() As Boolean
    On Error Resume Next
    Dim strSearch As String
    
    If Not IsArray(mstrField) Then Resume NoField
    If Not IsArray(mvarData) Then Resume NoData
    If UBound(mstrField) < 1 Then Resume NoField
    On Error GoTo E
    Dim i As Integer, strValue As String, strSql As String
    Dim adoRst As New ADODB.Recordset, j As Integer
    

    '先整理KEY
    If Not IsArray(mstrKeyField) Then
        ReDim mstrKeyField(0) As Variant
        mstrKeyField(0) = mstrField(0)
    End If
    
    For i = 0 To UBound(mstrField)
        strValue = strValue & "," & mstrField(i)
    Next i
    
    If Len(Trim(strValue)) > 1 Then
        strValue = Right(strValue, Len(strValue) - 1)
        strSql = "Select " & strValue & " From " & mstrTableName & " "
    '不可以没有被选取的字段
    Else
        Exit Function
    End If
    adoRst.CursorLocation = adUseClient
    With adoRst
        '根据varData逐条记录更新表
        For i = 0 To UBound(mvarData)
            Select Case mvarData(i)(mstrKeyField(0))
                '表示新增记录
                Case 0
                    .Open strSql & " Where 1=0", mAdoConn, adOpenDynamic, adLockOptimistic
                    .AddNew
                    On Error Resume Next
                    For j = 0 To adoRst.Fields.Count - 1
                        .Fields(j).Value = mvarData(i)(mstrField(j))
                    Next j
                    On Error GoTo E
                    .Update
                    .Close
                '表示删除记录
                Case -1
                    strSearch = ""
                    For j = 0 To UBound(mstrKeyField)
                       If strSearch = "" Then
                           strSearch = mstrField(j) & "=" & mvarData(i)(mstrField(j))
                       Else
                          strSearch = strSearch & " And " & mstrField(j) & "=" & mvarData(i)(mstrField(j))
                       End If
                    Next j
                     
                    mAdoConn.Execute "Delete From " & mstrTableName & " Where " & strSearch
                '表示更新记录
                Case Else
                    strSearch = ""
                    For j = 0 To UBound(mstrKeyField)
                       If strSearch = "" Then
                           strSearch = mstrField(j) & "=" & mvarData(i)(mstrField(j))
                       Else
                          strSearch = strSearch & " And " & mstrField(j) & "=" & mvarData(i)(mstrField(j))
                       End If
                    Next j
                    .Open strSql & " Where " & strSearch, mAdoConn, adOpenDynamic, adLockOptimistic
                    If Not .EOF Then
                        On Error Resume Next
                        For j = 0 To adoRst.Fields.Count - 1
                            .Fields(j).Value = mvarData(i)(mstrField(j))
                        Next j
                        On Error GoTo E
                        .Update
                    End If
                    .Close
            End Select
        Next i
    End With

    
ExitEntry:
    Save = True
    mlngErrNo = 0
    mstrErrDescription = ""
    Exit Function
NoField:
    Save = False
    mlngErrNo = -1
    mstrErrDescription = "字段集合未定义或数目不够。"
    Exit Function
NoData:
    Save = False
    mlngErrNo = -1
    mstrErrDescription = "没有数据，无需保存。"
    Exit Function
E:
    Save = False
    mlngErrNo = Err.Number
    mstrErrDescription = Err.Description
End Function

Public Sub Init()
    On Error Resume Next
    Dim var As Variant
    
    mstrField = var
    mbIsDataAdded = False
    mCurPosition = -1
    mvarData = var
    mstrTableName = ""
    mstrKeyField = var
    mlngErrNo = 0
    mstrErrDescription = ""
    If Not mAdoConn Is Nothing Then
        Set mAdoConn = Nothing
    End If
End Sub