ado.cls

VB中的ADO操作教程

            pSQL = pSQL & "{SELECT TOP " & MaxRecords & " [@PARENTFIELDS]"
        End If
    Else
        pSQL = pSQL & "{SELECT " & "[@PARENTFIELDS]"
    End If
    pSQL = pSQL & " FROM [@PARENT]"
    pSQL = pSQL & " [@WHEREPARENT]"
    pSQL = pSQL & " [@ORDPARENT]} "
    'Substitute for actual values
    pSQL = Replace(pSQL, "[@PARENTFIELDS]", ParentFields)
    pSQL = Replace(pSQL, "[@PARENT]", tblParent)
    pSQL = Replace(pSQL, "[@WHEREPARENT]", pWhere)
    pSQL = Replace(pSQL, "[@ORDPARENT]", pOrder)
    'Define Child SQL Statement
    cSQL = ""
    cSQL = cSQL & "{SELECT " & "[@CHILDFIELDS]"
    cSQL = cSQL & " FROM [@CHILD]"
    cSQL = cSQL & " [@WHERECHILD]"
    cSQL = cSQL & " [@ORDCHILD]} "
    'Substitute for actual values
    cSQL = Replace(cSQL, "[@CHILDFIELDS]", ChildFields)
    cSQL = Replace(cSQL, "[@CHILD]", tblChild)
    cSQL = Replace(cSQL, "[@WHERECHILD]", cWhere)
    cSQL = Replace(cSQL, "[@ORDCHILD]", cOrder)

    'Define Parent Properties
    lSQL = "SHAPE " & pSQL & vbCrLf
    'Define Child Properties
    lSQL = lSQL & "APPEND (" & cSQL & " RELATE " & fldParent & " TO " & fldChild & ") AS ChildItems"
    'TODO: - lSQL = TrimALL(lSQL)

    'Get the data
    LastSQL = lSQL

    Set DataShape = New ADODB.Recordset

    With DataShape
        .CursorType = CursorType
        .LockType = LockType
        .Source = lSQL
        .ActiveConnection = ConObject(ConnectDataShape)
        .Open
        If Disconnected Then Set .ActiveConnection = Nothing
    End With

Exit Function

LocalError:
    LastError = Err.Source & " (" & Err.Number & ") " & Err.Description
End Function

Public Function EmptyRS(ByVal oRS) As Boolean

    On Error Resume Next
    'Checks for an EMPTY RecordSet
    EmptyRS = True
    If Not oRS Is Nothing Then
        EmptyRS = ((oRS.BOF = True) And (oRS.EOF = True))
    End If

End Function

Public Sub ErrorClear()
    LastError = ""
End Sub

Public Function Execute(SQL) As Boolean

    On Error GoTo LocalError

    If Connect(ConnectServerSide) Then
        LastSQL = CStr(SQL)
        With cnSVR
            .BeginTrans
            .Execute CStr(SQL)
            .CommitTrans
        End With
    End If
    Execute = True

Exit Function

LocalError:
    LastError = Err.Source & " (" & Err.Number & ") " & Err.Description

    If cnSVR.State = adStateOpen Then
        cnSVR.RollbackTrans
    End If

End Function

'Tested with ACCESS 2000 and SQL7.0 using ADO2.5
Public Function ExecuteID(SQL) As Long

    On Error GoTo LocalError

    Dim oRS     As New ADODB.Recordset

    With oRS
        'Prepare the RecordSet
        .CursorLocation = adUseServer
        .CursorType = adOpenForwardOnly
        .LockType = adLockReadOnly
        .Source = "SELECT @@IDENTITY"
    End With

    If Connect(ConnectServerSide) Then
        With cnSVR  'NB: Server Side Connection
            .ConnectionString = ConnectString
            .CursorLocation = adUseServer
            .Open
            LastSQL = CStr(SQL)
            .BeginTrans
            .Execute CStr(SQL), , adCmdText + adExecuteNoRecords
            .CommitTrans
            oRS.ActiveConnection = cnSVR
            oRS.Open , , , , adCmdText
            ExecuteID = oRS(0).Value
            oRS.Close
            .Close
        End With
    End If

ExitHere:
    If oRS.State = adStateOpen Then oRS.Close
    Set oRS = Nothing
Exit Function

LocalError:
    LastError = Err.Source & " (" & Err.Number & ") " & Err.Description
    On Error Resume Next
    If cnSVR.State = adStateOpen Then cnSVR.RollbackTrans
    Resume ExitHere
End Function

Public Function GetCount(TableName As Variant, Optional WhereClause As Variant = "") As Long

    Dim oRS As ADODB.Recordset
    Dim lSQL As String

    On Error GoTo LocalError

    TableName = CStr(TableName)
    WhereClause = CStr(WhereClause)
    GetCount = -1
    GetCount = 0

    If WhereClause <> "" Then
        lSQL = "Select COUNT (*) FROM " & TableName & " WHERE " & WhereClause
    Else
        lSQL = "Select COUNT (*) FROM " & TableName
    End If

    If Connect(ConnectServerSide) Then
        LastSQL = lSQL
        Set oRS = New ADODB.Recordset
        With cnSVR
            Set oRS = .Execute(lSQL)
            GetCount = oRS.Fields(0).Value
            oRS.Close
        End With
    End If

    If Not oRS Is Nothing Then Set oRS = Nothing

Exit Function

LocalError:
    LastError = Err.Source & " (" & Err.Number & ") " & Err.Description
    If Not oRS Is Nothing Then Set oRS = Nothing
End Function

Public Function GetIncrement(TableName As String, FieldName As String, KeyField As String, KeyID As Variant) As Long

    'This function gets a Field Value
    '   Increments its Value by ONE and saves the result

    Dim oRS     As ADODB.Recordset
    Dim NextNum As Long
    Dim numSQL  As String
    Dim updSQL  As String
    Dim Started As Date
    
    If cnSVR Is Nothing Then Set cnSVR = New ADODB.Connection
    Set oRS = New ADODB.Recordset

    With SmartSQL
        .StatementType = TYPE_SELECT
        .AddTable TableName
        .AddField FieldName
        .AddSimpleWhereClause KeyField, KeyID
        numSQL = MySQL
    End With

    With oRS    'Prepare the RecordSet
        .CursorLocation = adUseServer
        .CursorType = adOpenDynamic
        .LockType = adLockPessimistic
        .Source = numSQL
    End With

    If Connect(ConnectServerSide) Then
        With cnSVR  'NB: Server Side Connection
            .ConnectionString = ConnectString
            .CursorLocation = adUseServer
            .Open
            .BeginTrans
            Set oRS.ActiveConnection = cnSVR
            oRS.Open
            NextNum = oRS(0) + 1
            oRS(0) = NextNum
            oRS.Update
            .CommitTrans
            oRS.Close
            .Close
        End With
        GetIncrement = NextNum
    End If

ExitHere:
    Set oRS = Nothing
Exit Function

LocalError:
    LastError = Err.Source & " (" & Err.Number & ") " & Err.Description
    On Error Resume Next
    If cnSVR.State = adStateOpen Then cnSVR.RollbackTrans
    If oRS.State = adStateOpen Then oRS.Close
    Resume ExitHere
End Function

Public Function GetRS(SQL As Variant, Optional LockType As ADODB.LockTypeEnum = adLockReadOnly, Optional CursorType As ADODB.CursorTypeEnum = adOpenStatic, Optional Disconnected As Boolean = True, Optional ConnectType As ADOConnectType = ConnectClientSide) As ADODB.Recordset

    On Error GoTo LocalError

    LastSQL = CStr(SQL)

    Set GetRS = New ADODB.Recordset

    With GetRS
        .LockType = LockType
        .CursorType = CursorType
        .Source = CStr(SQL)
        .ActiveConnection = ConObject(ConnectType)
        .Open
        If Disconnected Then Set .ActiveConnection = Nothing
    End With

Exit Function

LocalError:
    LastError = Err.Source & " (" & Err.Number & ") " & Err.Description
End Function

Public Function Find(oRS As ADODB.Recordset, ThisField As ADODB.Field, ThisItem As Variant, Optional Operator As CLAUSE_OPERATOR = CLAUSE_EQUALS)

    On Error GoTo LocalError

    Dim lFindString As String

    If EmptyRS(oRS) Then Exit Function

    SmartSQL.Reset
    lFindString = SmartSQL.AddSimpleWhereClause(ThisField.Name, ThisItem, , Operator)
    SmartSQL.Reset

    With oRS
        'Try forward First
        .Find lFindString, , adSearchForward
        If .EOF Then    'Try backward next
            .Find lFindString, , adSearchBackward
        End If
        Find = Not .BOF 'Success or Failure
    End With

LocalError:
End Function

Public Function ImageLoad(oPictureControl As Object, adoRS As ADODB.Recordset, sFieldName As String) As Boolean
'    Dim oPict       As StdPicture
'    Dim sDir        As String
'    Dim sTempFile   As String
'    Dim iFileNum    As Integer
'    Dim lFileLength As Long
'    Dim abBytes()   As Byte
'    Dim iCtr        As Integer
'
'    On Error GoTo ErrHandler
'
'    sTempFile = oUtils.MyComputer.Directory(dirTEMP) & "tmpImage"
'    If oUtils.FileExists(sTempFile) Then Kill sTempFile
'
'    iFileNum = FreeFile
'    Open sTempFile For Binary As #iFileNum
'        lFileLength = LenB(adoRS(sFieldName))
'        abBytes = adoRS(sFieldName).GetChunk(lFileLength)
'        Put #iFileNum, , abBytes()
'    Close #iFileNum
'
'    oPictureControl.Picture = LoadPicture(sTempFile)
'
'    Kill sTempFile
'    ImageLoad = True
'
'Exit Function
'ErrHandler:
'    ImageLoad = False
'    Debug.Print Err.Description
End Function

Public Function ImageSave(oPictureControl As Object, adoRS As ADODB.Recordset, sFieldName As String) As Boolean

'    Dim oPict       As StdPicture
'    Dim sDir        As String
'    Dim sTempFile   As String
'    Dim iFileNum    As Integer
'    Dim lFileLength As Long
'    Dim abBytes()   As Byte
'    Dim iCtr        As Integer
'
'    On Error GoTo ErrHandler
'
'    Set oPict = oPictureControl.Picture
'
'    If oPict Is Nothing Then
'        ImageSave = False
'        Exit Function
'    End If