ado.cls

VB中的ADO操作教程

'
'    'Save picture to temp file
'    sTempFile = oUtils.MyComputer.Directory(dirTEMP) & "tmpImage"
'    If oUtils.FileExists(sTempFile) Then Kill sTempFile
'    SavePicture oPict, sTempFile
'
'    'read file contents to byte array
'    iFileNum = FreeFile
'    Open sTempFile For Binary Access Read As #iFileNum
'        lFileLength = LOF(iFileNum)
'        ReDim abBytes(lFileLength)
'        Get #iFileNum, , abBytes()
'        'put byte array contents into db field
'        adoRS.Fields(sFieldName).AppendChunk abBytes()
'    Close #iFileNum
'
'    'Don't return false if file can't be deleted
'    On Error Resume Next
'    Kill sTempFile
'    ImageSave = True
'
'Exit Function
'ErrHandler:
'    ImageSave = False
'    Debug.Print Err.Description
End Function

Public Function Mask(pDataType As ADODB.DataTypeEnum, pDataValue As Variant) As String

    On Error Resume Next

    Select Case pDataType
        Case adChapter, adArray 'Nothing we can do with this
        Case adBSTR, adChar, adLongVarChar, adLongVarWChar, adVarChar, adVarWChar, adWChar
            'Add single quotes around string values and remove single quotes from within the string.
            Mask = "'" & sqlEncode(CStr(pDataValue)) & "'"
        Case adDBDate, adDBTime, adDBTime, adDBTimeStamp, adFileTime
            'Add Hash Marks around dates/times.
            Mask = SmartSQL.prepDateForSQL(CDate(pDataValue))
        Case adBoolean
            Mask = SQLBoolean(CBool(pDataValue))
        Case Else   'It is Numeric
            Mask = pDataValue
    End Select

End Function

Public Function Optimize(ByVal oRS As Recordset, ByVal sField As String) As Boolean

    On Error GoTo LocalError

    'Create an Index for the specified field
    ' automaticaly uses the index for any Find, Sort, and Filter
    ' operations on the Recordset:
    If EmptyRS(oRS) Then
        'Do Nothing
    ElseIf oRS.CursorLocation = adUseClient Then
        'Works ONLY on Client Side record sets
        oRS.Fields(sField).Properties("OPTIMIZE").Value = True
    End If
    Optimize = True
Exit Function

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

Public Function PutRS(ByRef oRS As ADODB.Recordset) As Boolean

    On Error GoTo LocalError

    Dim Disconnected As Boolean

    Disconnected = oRS.ActiveConnection Is Nothing

    If EmptyRS(oRS) Then
        Exit Function
    ElseIf oRS.LockType = adLockReadOnly Then
        Exit Function
    ElseIf Disconnected Then
        Dim lField As ADODB.Field
        Dim lDirty As Boolean

        cnADX.BeginTrans
        With oRS
            .MoveFirst
            SmartSQL.Reset
            SmartSQL.AddTable oRS.DataMember
            While Not .EOF
                lDirty = False
                For Each lField In .Fields
                    If lField.Value <> lField.OriginalValue Then
                        lDirty = True
                        SmartSQL.AddField lField.Name
                        SmartSQL.AddValue lField.Value
                    End If
                Next lField
                If lDirty Then
                    SmartSQL.AddSimpleWhereClause oRS.Fields(0).Name, oRS.Fields(0).Value, , CLAUSE_EQUALS
                    If Not Execute(MySQL) Then
                        PutRS = False
                        Exit Function
                    End If
                End If
                .MoveNext
            Wend
            PutRS = True
        End With
    Else
        oRS.UpdateBatch adAffectAllChapters
        PutRS = True
    End If

    PutRS = True

Exit Function

LocalError:
    LastError = Err.Source & " (" & Err.Number & ") " & Err.Description
    If cnADO.State = adStateOpen Then
        cnADO.RollbackTrans
    End If
    PutRS = False
End Function

Function RecordsetToHTML(ByVal oRS As ADODB.Recordset, TableAttribs As Variant, Optional NullValues As Variant = "", Optional ShowFieldNames As Boolean = True, Optional IncludeWhiteSpace As Boolean = True) As String

    TableAttribs = CStr(TableAttribs)
    NullValues = CStr(NullValues)
    If NullValues = "" Then NullValues = "&nbsp;"

    Dim res As String
    Dim fld As ADODB.Field
    Dim tmp As String

    ' fill these variables only if spaces are to be kept
    ' prepare the <TABLE> tag
    res = "<TABLE " & TableAttribs & ">" & vbCrLf
    ' show field names, if required
    If ShowFieldNames Then
        res = res & vbTab & "<HEAD>" & vbCrLf
        For Each fld In oRS.Fields
            res = res & vbTab & vbTab & "<TD><B>" & fld.Name & "</B></TD>" & vbCrLf
        Next
        res = res & vbTab & "</HEAD>" & vbCrLf
    End If
    ' get all the records in a semi-formatted string
    tmp = oRS.GetString(, , "</TD>" & vbCrLf & vbTab & vbTab & "<TD>", "</TD>" & vbCrLf & vbTab & "</TR>" & vbCrLf & vbTab & "<TR>" & vbCrLf & vbTab & vbTab & "<TD>", NullValues)
    ' strip what has been appended to the last cell of the last row
    tmp = Left(tmp, Len(tmp) - Len(vbCrLf & vbTab & "<TR>" & vbCrLf & vbTab & vbTab & "<TD>"))
    ' add opening tags to the first cell of the first row of the table and complete the table
    RecordsetToHTML = res & vbTab & "<TR>" & vbCrLf & vbTab & vbTab & "<TD>" & tmp & vbCrLf & "</TABLE>"

End Function

Public Function RefreshRS(ByRef oRS As ADODB.Recordset) As Boolean

    If oRS Is Nothing Then Exit Function

    On Error GoTo LocalError

    Dim Disconnected As Boolean

    With oRS
        If oRS.ActiveConnection Is Nothing Then
            Disconnected = True
            If Connect(False) Then
                Set .ActiveConnection = cnADO
            Else
                Exit Function
            End If
        End If
        'Requery the Recordset
        .Requery
        .MoveFirst
        If Disconnected Then Set .ActiveConnection = Nothing
    End With

    RefreshRS = Not EmptyRS(oRS)
Exit Function

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

Public Function RS2XML(ByVal oRS As ADODB.Recordset, FullPath As String) As Boolean

    On Error GoTo LocalError

    FullPath = CStr(FullPath)
    On Error GoTo 0
    oRS.Save FullPath, adPersistXML
    RS2XML = True
Exit Function

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

Public Function XML2RS(FullPath As Variant) As ADODB.Recordset

    On Error GoTo LocalError

    Set XML2RS = New ADODB.Recordset
    XML2RS.Open FullPath, "Provider=MSPersist;", adOpenForwardOnly, adLockReadOnly, adCmdFile
Exit Function

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

Public Function Schema(SchemaType As ADODB.SchemaEnum, ParamArray Criteria() As Variant) As ADODB.Recordset
    If Connect(False) Then Set Schema = cnADO.OpenSchema(adSchemaColumns, Criteria)
End Function

Public Function SQLBoolean(TrueFalse As Boolean) As Integer

    'This is because SQL True = 1 & VB True = -1
    SQLBoolean = TrueFalse
    If IsSQL Then If TrueFalse = True Then SQLBoolean = TrueFalse * TrueFalse

End Function

Public Function sqlEncode(sqlValue, Optional Encapsulate As Boolean = False) As String

    On Error Resume Next

    sqlEncode = CStr(Replace(sqlValue, "'", "''"))
    If Encapsulate Then sqlEncode = "'" & sqlEncode & "'"

End Function

'##################
'# Class Specific #
'##################
Private Sub Class_Initialize()

    Set SmartSQL = New SmartSQL

End Sub

Private Sub Class_Terminate()

    On Error Resume Next

    CloseALL

    Set SmartSQL = Nothing
    Set cnADO = Nothing
    Set cnADX = Nothing
    Set cnSVR = Nothing

End Sub

Private Sub cnADO_BeginTransComplete(ByVal TransactionLevel As Long, ByVal pError As ADODB.Error, adStatus As ADODB.EventStatusEnum, ByVal pConnection As ADODB.Connection)
    'Transaction has begun
End Sub

Private Sub cnADO_CommitTransComplete(ByVal pError As ADODB.Error, adStatus As ADODB.EventStatusEnum, ByVal pConnection As ADODB.Connection)
    'Transaction commited
End Sub

Private Sub cnADO_ConnectComplete(ByVal pError As ADODB.Error, adStatus As ADODB.EventStatusEnum, ByVal pConnection As ADODB.Connection)
    'Connect
End Sub

Private Sub cnADO_Disconnect(adStatus As ADODB.EventStatusEnum, ByVal pConnection As ADODB.Connection)
    'Disconnect
End Sub

Private Sub cnADO_ExecuteComplete(ByVal RecordsAffected As Long, ByVal pError As ADODB.Error, adStatus As ADODB.EventStatusEnum, ByVal pCommand As ADODB.Command, ByVal pRecordset As ADODB.Recordset, ByVal pConnection As ADODB.Connection)
    'Transaction executed
End Sub

Private Sub cnADO_InfoMessage(ByVal pError As ADODB.Error, adStatus As ADODB.EventStatusEnum, ByVal pConnection As ADODB.Connection)
    'Status of Event
End Sub

Private Sub cnADO_RollbackTransComplete(ByVal pError As ADODB.Error, adStatus As ADODB.EventStatusEnum, ByVal pConnection As ADODB.Connection)
    'Transaction rolled back
End Sub

Private Sub cnADO_WillConnect(ConnectionString As String, UserID As String, Password As String, Options As Long, adStatus As ADODB.EventStatusEnum, ByVal pConnection As ADODB.Connection)
    'Connecting
End Sub

Private Sub cnADO_WillExecute(Source As String, CursorType As ADODB.CursorTypeEnum, LockType As ADODB.LockTypeEnum, Options As Long, adStatus As ADODB.EventStatusEnum, ByVal pCommand As ADODB.Command, ByVal pRecordset As ADODB.Recordset, ByVal pConnection As ADODB.Connection)
    'About to Execute
End Sub

Private Sub cnADX_BeginTransComplete(ByVal TransactionLevel As Long, ByVal pError As ADODB.Error, adStatus As ADODB.EventStatusEnum, ByVal pConnection As ADODB.Connection)
    'Transaction has begun
End Sub

Private Sub cnADX_CommitTransComplete(ByVal pError As ADODB.Error, adStatus As ADODB.EventStatusEnum, ByVal pConnection As ADODB.Connection)
    'Transaction commited
End Sub

Private Sub cnADX_ConnectComplete(ByVal pError As ADODB.Error, adStatus As ADODB.EventStatusEnum, ByVal pConnection As ADODB.Connection)
    'Connect
End Sub

Private Sub cnADX_Disconnect(adStatus As ADODB.EventStatusEnum, ByVal pConnection As ADODB.Connection)
    'Disconnect
End Sub

Private Sub cnADX_ExecuteComplete(ByVal RecordsAffected As Long, ByVal pError As ADODB.Error, adStatus As ADODB.EventStatusEnum, ByVal pCommand As ADODB.Command, ByVal pRecordset As ADODB.Recordset, ByVal pConnection As ADODB.Connection)
    'Transaction executed
End Sub

Private Sub cnADX_InfoMessage(ByVal pError As ADODB.Error, adStatus As ADODB.EventStatusEnum, ByVal pConnection As ADODB.Connection)
    'Status of Event
End Sub

Private Sub cnADX_RollbackTransComplete(ByVal pError As ADODB.Error, adStatus As ADODB.EventStatusEnum, ByVal pConnection As ADODB.Connection)
    'Transaction rolled back
End Sub

Private Sub cnADX_WillConnect(ConnectionString As String, UserID As String, Password As String, Options As Long, adStatus As ADODB.EventStatusEnum, ByVal pConnection As ADODB.Connection)
    'Connecting
End Sub

Private Sub cnADX_WillExecute(Source As String, CursorType As ADODB.CursorTypeEnum, LockType As ADODB.LockTypeEnum, Options As Long, adStatus As ADODB.EventStatusEnum, ByVal pCommand As ADODB.Command, ByVal pRecordset As ADODB.Recordset, ByVal pConnection As ADODB.Connection)
    'About to Execute
End Sub