ado.cls

VB中的ADO操作教程

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "adoUtils"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit
Option Compare Text

#If False Then
    Private ConnectClientSide
    Private ConnectDataShape
    Private ConnectServerSide
#End If

Public Enum ADOConnectType
    ConnectClientSide
    ConnectDataShape
    ConnectServerSide
End Enum

Private Const mModName  As String = "ADO Utilities"
Private Const sqlDSN    As String = "DRIVER={SQL SERVER};Provider=SQLOLEDB.1;Server=[+SERVER+];Database=[+DATABASE+];UID=[+UID+];pwd=[+PWD+];"
Private Const mdbDSN    As String = "Provider=Microsoft.Jet.OLEDB.4.0;Password=[+PWD+];User ID=[+UID+];Data Source=[+SERVER+][+DATABASE+];Mode=Share Deny None;Extended Properties=;Jet OLEDB:System database=;Jet OLEDB:Registry Path=;Jet OLEDB:Database Password=;Jet OLEDB:Engine Type=5;Jet OLEDB:Database Locking Mode=1;Jet OLEDB:Global Partial Bulk Ops=2;Jet OLEDB:Global Bulk Transactions=1;Jet OLEDB:New Database Password=;Jet OLEDB:Create System Database=False;Jet OLEDB:Encrypt Database=False;Jet OLEDB:Don't Copy Locale on Compact=False;Jet OLEDB:Compact Without Replica Repair=False;Jet OLEDB:SFP=False"

Private mConnectString        As String
Private mLastError      As String
Private mLastSQL        As String
Private mWinHandle      As Long

Public WithEvents cnADO As ADODB.Connection     'Standard Connection
Attribute cnADO.VB_VarHelpID = -1
Public WithEvents cnADX As ADODB.Connection     'DataShape Connection
Attribute cnADX.VB_VarHelpID = -1
Public WithEvents cnSVR As ADODB.Connection     'Server Side Connection
Attribute cnSVR.VB_VarHelpID = -1

Public SmartSQL As SmartSQL

'####################
'# Class Properties #
'####################

Public Property Let ConnectString(vData As String)
    mConnectString = vData
End Property
Public Property Get ConnectString() As String
    ConnectString = mConnectString
End Property

Public Property Get DBLocation() As String

    Static mDBLocation  As String
    Dim lTemp           As Variant

    If Len(mDBLocation) = 0 Then
        Dim x As Integer
        lTemp = Split(ConnectString, ";")
        If IsArray(lTemp) Then
            For x = LBound(lTemp) To UBound(lTemp)
                If Left(UCase(lTemp(x)), 12) = "DATA SOURCE=" Then
                    mDBLocation = Replace(lTemp(x), "DATA SOURCE=", "", , , vbTextCompare)
                    mDBLocation = Replace(mDBLocation, ".mdb", "")
                    Exit For
                End If
            Next x
        End If
    End If

    DBLocation = mDBLocation

End Property

Public Property Get DBPath() As String
    'TODO: - DBPath = oUtils.FilePart(DBLocation, FilePathOnly)
End Property

Public Property Get DBName() As String
    'TODO - DBName = oUtils.FilePart(DBLocation, FileNameOnly)
End Property

Private Property Get IsSQL() As Boolean
    IsSQL = SmartSQL.SQLType = SQL_TYPE_ANSI
End Property

Public Property Let LastError(vData As String)
    If Len(mLastError) = 0 Then mLastError = vData
End Property
Public Property Get LastError() As String
    LastError = mLastError
End Property

Public Property Let LastSQL(vData As String)
    mLastSQL = vData
End Property
Public Property Get LastSQL() As String
    LastSQL = mLastSQL
End Property

Public Property Get MySQL() As String
    MySQL = SmartSQL.SQL
    SmartSQL.Reset
End Property

Public Property Let WinHandle(vData As Long)
    mWinHandle = vData
End Property
Public Property Get WinHandle() As Long
    WinHandle = mWinHandle
End Property

'####################
'# Public Functions #
'####################

Public Function Connect(ConnectType As ADOConnectType, Optional wHandle As Long) As Boolean

    On Error GoTo LocalError

    If Len(ConnectString) = 0 Then Exit Function

    Select Case ConnectType
        Case ConnectClientSide                      ' Client Side Connection
            If cnADO Is Nothing Then Set cnADO = New ADODB.Connection
            With cnADO
                If .State = adStateOpen Then        ' Already Connected
                    Connect = True
                Else                                ' Try and establish a connection
                    .ConnectionString = ConnectString
                    .CursorLocation = adUseClient
                    .Open
                    Connect = True
                End If
                If .State Then .Errors.Clear
            End With

        Case ConnectDataShape                       ' Data Shape Connection
            If cnADX Is Nothing Then Set cnADX = New ADODB.Connection
            With cnADX
                If .State = adStateOpen Then        ' Already Connected
                    Connect = True
                Else                                ' Try and establish a connection
                    If IsSQL Then                   ' Use MS SQL Connection
                        .ConnectionString = Replace(ConnectString, "Provider=SQLOLEDB.1;", "Data Provider=MSDASQL;", 1, -1, 1)
                    Else                            ' Use MS Access Connection
                        .ConnectionString = Replace(ConnectString, "Provider=", "Data Provider=", 1, -1, 1)
                    End If
                    .CursorLocation = adUseServer
                    .Provider = "MSDataShape"
                    .Open
                    Connect = True
                End If
                If .State Then .Errors.Clear
            End With

        Case ConnectServerSide
            If cnSVR Is Nothing Then Set cnSVR = New ADODB.Connection
            With cnSVR
                If .State = adStateOpen Then        ' Already Connected
                    Connect = True
                Else                                ' Try and establish a connection
                    .ConnectionString = ConnectString
                    .CursorLocation = adUseServer
                    .Open
                    Connect = True
                End If
                If .State Then .Errors.Clear
            End With

        Case Else:  'mmm....

    End Select

Exit Function

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

Private Function ConObject(ConnectType As ADOConnectType) As ADODB.Connection
    Select Case ConnectType
        Case ConnectClientSide:   If Connect(ConnectType) = True Then Set ConObject = cnADO
        Case ConnectDataShape:    If Connect(ConnectType) = True Then Set ConObject = cnADX
        Case ConnectServerSide:   If Connect(ConnectType) = True Then Set ConObject = cnSVR
        Case Else:  'mmm....
    End Select
End Function

Public Function CloseALL() As Boolean

    On Error GoTo ErrHandler

    If Not cnADO Is Nothing Then If cnADO.State Then cnADO.Close
    If Not cnADX Is Nothing Then If cnADX.State Then cnADX.Close
    If Not cnSVR Is Nothing Then If cnSVR.State Then cnSVR.Close

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

    CloseALL = True

ErrHandler:
End Function

Public Function Clone(ByVal oRS As ADODB.Recordset, Optional LockType As LockTypeEnum = adLockUnspecified) As ADODB.Recordset

    On Error GoTo LocalError

    Set Clone = New ADODB.Recordset

    'This is very efficient
    Dim stm As ADODB.Stream
    Set stm = New ADODB.Stream

    oRS.Fields.Append "Child", adVariant
    oRS.Save stm
    Clone.Open stm, , , LockType

Exit Function

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

Public Function CloneFieldStructure(ByVal oRS) As ADODB.Recordset

    On Error GoTo LocalError

    Dim fld As ADODB.Field

    Set CloneFieldStructure = New ADODB.Recordset

    ' create a set of fields with same attributes
    For Each fld In oRS.Fields
        CloneFieldStructure.Fields.Append fld.Name, fld.Type, fld.DefinedSize, fld.Attributes
        'special handling for data types with numeric scale & precision
        Select Case fld.Type
            Case adNumeric, adDecimal
                With CloneFieldStructure
                    .Fields(.Fields.Count - 1).Precision = fld.Precision
                    .Fields(.Fields.Count - 1).NumericScale = fld.NumericScale
                End With
        End Select
    Next

Exit Function

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

Public Function DataShape(ByVal tblParent, _
                          ByVal tblChild, _
                          ByVal fldParent, _
                          ByVal fldChild, _
                          Optional ordParent = "", _
                          Optional ordChild = "", _
                          Optional WhereParent = "", _
                          Optional WhereChild = "", _
                          Optional ParentFields = "", _
                          Optional ChildFields = "", _
                          Optional MaxRecords = 0, _
                          Optional LockType As ADODB.LockTypeEnum = adLockReadOnly, _
                          Optional CursorType As ADODB.CursorTypeEnum = adOpenStatic, _
                          Optional Disconnected As Boolean = True) As ADODB.Recordset
    '=========================================================
    'This function will return a SHAPEd RecordSet
    'Assumptions:
    '
    'tblParent      = Valid Table in the Database   - String \ Parent Table
    'tblChild       = Valid Table in the Database   - String / Child  Table
    '
    'fldParent      = Valid Field in Parent Table   - String \ relate this field
    'fldChild       = Valid Field in Child Table    - String / ..to this field
    '
    'ordParent      = Valid Field in Parent Table   - String \ ordering
    'ordChild       = Valid Field in Child Table    - String /
    '
    'WhereParent    = Valid SQL Where Clause        - Variant (Optional)
    'WhereChild     = Valid SQL Where Clause        - Variant (Optional)
    '
    'ParentFields   = Specific Fields to return     - String (pipe delimitered)
    'ChildFields    = Specific Fields to return     - String (pipe delimitered)
    'MaxRecords     = Specify Maximum Child Records - Long (0 = ALL)
    '=========================================================
    If Len(WhereChild) = 0 Then WhereChild = ""
    If Len(ParentFields) = 0 Then ParentFields = "*"
    If Len(ChildFields) = 0 Then ChildFields = "*"
    If Len(MaxRecords) = 0 Then MaxRecords = 0
    If Len(LockType) = 0 Then LockType = adLockReadOnly
    If Len(CursorType) = 0 Then CursorType = adOpenStatic
    If Len(Disconnected) = 0 Then Disconnected = True

    Dim lSQL As String
    Dim pSQL As String
    Dim cSQL As String
    Dim pWhere As String
    Dim cWhere As String
    Dim pOrder As String
    Dim cOrder As String

    On Error GoTo LocalError
    'Define the SQL Statement
    lSQL = ""
    ParentFields = CStr(Replace(ParentFields, "|", ", "))
    ChildFields = CStr(Replace(ChildFields, "|", ", "))
    pWhere = CStr(WhereParent)
    cWhere = CStr(WhereChild)
    pOrder = CStr(ordParent)
    cOrder = CStr(ordChild)
    If pWhere <> "" Then pWhere = " WHERE " & pWhere
    If cWhere <> "" Then cWhere = " WHERE " & cWhere
    If pOrder <> "" Then pOrder = " ORDER By " & pOrder
    If cOrder <> "" Then cOrder = " ORDER By " & cOrder
    'Define Parent SQL Statement
    pSQL = ""
    If MaxRecords > 0 Then
        If IsSQL Then
            pSQL = pSQL & "{SET ROWCOUNT " & MaxRecords & " SELECT [@PARENTFIELDS]"
        Else