crecord.cls

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

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "CRecord"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
Option Explicit
Private mstrField  As Variant
Private mlngKeyCount As Long

Private mbIsDataAdded As Boolean
Private mCurPosition As Integer

Private mvarData As Variant
Private mstrTableName As String
Private mstrKeyField  As Variant

Private mlngErrNo  As Long
Private mstrErrDescription As String

Private mAdoConn As ADODB.Connection

'******************************************************************************
'目的：     取得活动连接
'输入：
'返回：     错误号
'******************************************************************************
Public Property Let DBConnect(ByRef AdoConn As ADODB.Connection)
    Set mAdoConn = AdoConn
End Property

'******************************************************************************
'目的：     取得当前错误号
'输入：
'返回：     错误号
'******************************************************************************
Public Property Get ErrNo() As Long
    ErrNo = mlngErrNo
    
End Property


'******************************************************************************
'目的：     取得当前错误描述
'输入：
'返回：     错误描述
'******************************************************************************
Public Property Get ErrDescription() As String
    ErrDescription = mstrErrDescription
End Property

'******************************************************************************
'目的：取得字段名称
'输入：字段顺序号
'返回：字段名
'******************************************************************************

Public Property Get FieldName(ByVal Item As Long) As String
    On Error Resume Next
    
    If Not IsArray(mstrField) Then Exit Property
    If UBound(mstrField) >= Val(Item) Then
        FieldName = mstrField(Val(Item))
    End If
End Property

'******************************************************************************
'目的：得到当前记录某字段值
'输入：字段名称或编号
'返回：当前记录某字段值
'******************************************************************************

Public Property Get Value(ByVal Field As Variant) As Variant
    On Error Resume Next
    
    If IsNumeric(Field) Then Field = Val(Field) + 1
    Value = mvarData(mCurPosition)(Field)
End Property

'******************************************************************************
'目的：设置/修改当前记录某字段值
'输入：字段名称或编号，要设置的值
'返回：
'******************************************************************************

Public Property Let Value(ByVal Field As Variant, ByVal varValue As Variant)
    On Error GoTo E
    Dim i As Integer, varTemp As Variant, sFieldName As String, lngItem As Long
    If IsArray(mstrField) Then
        If mbIsDataAdded Then
'            AddValue = False
            mlngErrNo = -1
            mstrErrDescription = "不允许在AddValue之后再修改字段信息。"
            Exit Property
        Else
            If UBound(mstrField) = 0 Then
'                AddValue = False
                mlngErrNo = -1
                mstrErrDescription = "不允许保存只有一个字段的结果。"
                Exit Property
            End If
        End If
    Else
'        AddValue = False
        mlngErrNo = -1
        mstrErrDescription = "请先使用AddField添加两个或两个以上字段。"
        Exit Property
    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
        On Error Resume Next
        mvarData(mCurPosition).Remove sFieldName
        On Error GoTo E
        mvarData(mCurPosition).Add varValue, sFieldName
    Else
        Resume InvalidField
    End If
        
ExitEntry:
    mbIsDataAdded = True
    mstrErrDescription = ""
    mlngErrNo = 0
    Exit Property
InvalidField:
    mstrErrDescription = "无效的字段。"
    mlngErrNo = -1
    Exit Property
E:
    mlngErrNo = Err.Number
    mstrErrDescription = Err.Description
End Property

'******************************************************************************
'目的：添加一个字段
'输入：字段名称
'返回：成功/失败
'******************************************************************************

Public Function AddField(ByVal strFieldName As String) As Boolean
    On Error GoTo E
    If mbIsDataAdded Then
        AddField = False
        mlngErrNo = -1
        mstrErrDescription = "不允许在AddValue之后再修改字段信息。"
        Exit Function
    End If
    
    If IsArray(mstrField) Then
        ReDim Preserve mstrField(UBound(mstrField) + 1) As String
    Else
        ReDim mstrField(0) As String
    End If
    
    mstrField(UBound(mstrField)) = strFieldName
ExitEntry:
    AddField = True
    mstrErrDescription = ""
    mlngErrNo = 0
    Exit Function
E:
    AddField = False
    mlngErrNo = Err.Number
    mstrErrDescription = Err.Description
End Function

'******************************************************************************
'目的：移动到下一条记录(记录为空时不可移动)
'输入：
'返回：成功/失败
'******************************************************************************

Public Function MoveNext() As Boolean
    On Error GoTo E
    
    If Not IsArray(mvarData) Then Resume ErrOut
    
    If UBound(mvarData) >= 0 Then
        If mCurPosition + 1 <= UBound(mvarData) Then
            mCurPosition = mCurPosition + 1
        Else
            mCurPosition = 0
        End If
    Else
        Resume ErrOut
    End If

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

ErrOut:
    mlngErrNo = -1
    mstrErrDescription = "目前记录为空，无法移动！"
    Exit Function

E:
    MoveNext = False
    mlngErrNo = Err.Number
    mstrErrDescription = Err.Description
End Function

'******************************************************************************
'目的：新增加一条记录
'输入：
'返回：成功/失败
'******************************************************************************

Public Function AddNew() As Boolean
    On Error GoTo E
    If IsArray(mvarData) Then
        ReDim Preserve mvarData(UBound(mvarData) + 1) As Variant
        Set mvarData(UBound(mvarData)) = New Collection
        mCurPosition = UBound(mvarData)
    Else
        ReDim mvarData(0) As Variant
        Set mvarData(0) = New Collection
        mCurPosition = 0
    End If
ExitEntry:
    AddNew = True
    mlngErrNo = 0
    mstrErrDescription = ""
    Exit Function
E:
    AddNew = False
    mlngErrNo = Err.Number
    mstrErrDescription = Err.Description
    
End Function


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


Public Function MoveFirst() As Boolean
    On Error GoTo E
    
    If Not IsArray(mvarData) Then Resume ErrOut
    
    If UBound(mvarData) >= 0 Then
        mCurPosition = 0
    Else
        Resume ErrOut
    End If

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

ErrOut:
    MoveFirst = False
    mlngErrNo = -1
    mstrErrDescription = "目前记录为空，无法移动！"
    Exit Function

E:
    MoveFirst = False
    mlngErrNo = Err.Number
    mstrErrDescription = Err.Description
End Function

'******************************************************************************
'目的：移动到某条记录
'输入：指定的记录
'返回：成功/失败
'******************************************************************************

Public Function Move(ByVal lngPostion As Long) As Boolean
    On Error GoTo E
    
    If Not IsArray(mvarData) Then Resume ErrOut
    
    If UBound(mvarData) >= 0 Then
        If lngPostion <= UBound(mvarData) Then
            mCurPosition = lngPostion
        Else
            Resume OutSpace
        End If
    Else