• Home
 · 
• Databases/Data Access/DAO/ADO
 · 
• Simplifies ADO 2.x access.

Simplifies ADO 2.x access.

Simplifies ADO 2.x access.

Rate Simplifies ADO 2.x access.

• 1
• 2
• 3
• 4
• 5

(1(1 Vote))

Private Const ConstCommandTimeout = 60
Private Const ConstDatabaseTimeout = 60

Private oDBConnection As New ADODB.Connection
Private oADOCommand As New ADODB.Command
Private oDbRecordSet As New ADODB.Recordset
Attribute oDbRecordSet.VB_VarHelpID = -1
Private iADODatabaseTimeout As Integer
Private iADOCommandTimeout As Integer
Private iCacheSize As Integer

Private lResult As Long

Private sDSN As String
Private sUserName As String
Private sPassword As String
Private sDatabase As String

Private lErrorNumber As Long
Private sErrorDescription As String
Private sErrorPlace As String

Private sODBCString As String
Private sProviderString As String

Private bLogFile As Boolean
Private sLogFilePath As String
Private iLogFileNumber As Integer

Private sSQLString As String

Private bProviderConnection As Boolean
Private bLogging As Boolean

Public Property Let LogFilePath(ByVal vData As String)
    sLogFilePath = vData
End Property

Public Property Get LogFilePath() As String
    LogFilePath = sLogFilePath
End Property

Public Property Let Logging(ByVal vData As Boolean)
    bLogging = vData
End Property

Public Property Get Logging() As Boolean
    Logging = bLogging
End Property

Public Property Get Connection() As ADODB.Connection
    Set Connection = oDBConnection
End Property

Public Sub Class_Initialize()
On Error GoTo errhandler
    Call Initialize
    Exit Sub
errhandler:
    lErrorNumber = Err.Number
    sErrorDescription = Err.Description
    sErrorPlace = "Class_Initialize()"
End Sub

Private Sub Initialize()
    bLogging = False
    iADOCommandTimeout = ConstCommandTimeout
    iADODatabaseTimeout = ConstDatabaseTimeout
    sDSN = ""
    sUserName = ""
    sPassword = ""
    sDatabase = ""
    sODBCString = ""
    sSQLString = ""
    lErrorNumber = 0
    sErrorDescription = ""
    sErrorPlace = ""
    sODBCString = ""
    sProviderString = ""
    sSQLString = ""
    sLogFilePath = ""
End Sub

Public Sub Class_Terminate()
    Call Initialize
    If (oDBConnection.State = 1) Then
        Me.CloseConnection
    End If
End Sub

Public Property Get VersionInfo() As String
    VersionInfo = App.Path + "\" + App.EXEName + "." + TypeName(Me) + _
            " " + CStr(App.Major) + _
            " . " + CStr(App.Minor) + " . " + CStr(App.Revision)
End Property

Public Property Get GetErrorNumber() As Long
    GetErrorNumber = lErrorNumber
End Property

Public Property Get GetErrorDescription() As String
    GetErrorDescription = sErrorDescription
End Property

Public Property Get GetErrorPlace() As String
    GetErrorPlace = sErrorPlace
End Property

Public Property Let DSN(ByVal inDSN As String)
    sDSN = inDSN
End Property

Public Property Get DSN() As String
    DSN = sDSN
End Property

Public Property Get RecordCount() As Integer
    RecordCount = oDbRecordSet.RecordCount
End Property

Public Property Let CacheSize(ByVal inCacheSize As Integer)
    iCacheSize = inCacheSize
End Property

Public Property Get CacheSize() As Integer
    CacheSize = iCacheSize
End Property

Public Property Let MaxRecords(ByVal inMaxRecords As Double)
On Error GoTo errhandler
    If (inMaxRecords > 0) Then
        oDbRecordSet.MaxRecords = inMaxRecords
    End If
    Exit Property
errhandler:
    lErrorNumber = Err.Number
    sErrorDescription = Err.Description
    sErrorPlace = "Let MaxRecords()"
End Property

Public Property Get MaxRecords() As Double
On Error GoTo errhandler
    MaxRecords = oDbRecordSet.MaxRecords
    Exit Property
errhandler:
    lErrorNumber = Err.Number
    sErrorDescription = Err.Description
    sErrorPlace = "Get MaxRecords()"
End Property

Public Property Let ProviderConnection(ByVal inValue As Boolean)
On Error GoTo errhandler
    bProviderConnection = inValue
    Exit Property
errhandler:
    lErrorNumber = Err.Number
    sErrorDescription = Err.Description
    sErrorPlace = "Let ProviderConnection()"
End Property

Public Property Get ProviderConnection() As Boolean
On Error GoTo errhandler
    ProviderConnection = bProviderConnection
    Exit Property
errhandler:
    lErrorNumber = Err.Number
    sErrorDescription = Err.Description
    sErrorPlace = "Get ProviderConnection()"
End Property

Public Property Let ADODatabaseTimeout(ByVal inADODatabaseTimeout As Integer)
On Error GoTo errhandler
    iADODatabaseTimeout = inADODatabaseTimeout
    Exit Property
errhandler:
    lErrorNumber = Err.Number
    sErrorDescription = Err.Description
    sErrorPlace = "Let ADODatabaseTimeout()"
End Property

Public Property Get ADODatabaseTimeout() As Integer
On Error GoTo errhandler
    ADODatabaseTimeout = iADODatabaseTimeout
    Exit Property
errhandler:
    lErrorNumber = Err.Number
    sErrorDescription = Err.Description
    sErrorPlace = "Get ADODatabaseTimeout()"
End Property

Public Property Let ADOCommandTimeout(ByVal inADOCommandTimeout As Integer)
On Error GoTo errhandler
    iADOCommandTimeout = inADOCommandTimeout
    Exit Property
errhandler:
    lErrorNumber = Err.Number
    sErrorDescription = Err.Description
    sErrorPlace = "Let ADOCommandTimeout()"
End Property

Public Property Get ADOCommandTimeout() As Integer
On Error GoTo errhandler
    ADOCommandTimeout = iADOCommandTimeout
    Exit Property
errhandler:
    lErrorNumber = Err.Number
    sErrorDescription = Err.Description
    sErrorPlace = "Get ADOCommandTimeout()"
End Property

Public Property Let UserName(ByVal inUserName As String)
On Error GoTo errhandler
    sUserName = inUserName
    Exit Property
errhandler:
    lErrorNumber = Err.Number
    sErrorDescription = Err.Description
    sErrorPlace = "Let UserName()"
End Property

Public Property Get UserName() As String
On Error GoTo errhandler
    UserName = sUserName
    Exit Property
errhandler:
    lErrorNumber = Err.Number
    sErrorDescription = Err.Description
    sErrorPlace = "Get UserName()"
End Property

Public Property Let Password(ByVal inPassword As String)
On Error GoTo errhandler
    sPassword = inPassword
    Exit Property
errhandler:
    lErrorNumber = Err.Number
    sErrorDescription = Err.Description
    sErrorPlace = "Let Password()"
End Property

Public Property Get Password() As String
On Error GoTo errhandler
    Password = sPassword
    Exit Property
errhandler:
    lErrorNumber = Err.Number
    sErrorDescription = Err.Description
    sErrorPlace = "Get Password()"
End Property

Public Property Let Database(ByVal inDatabase As String)
On Error GoTo errhandler
    sDatabase = inDatabase
    Exit Property
errhandler:
    lErrorNumber = Err.Number
    sErrorDescription = Err.Description
    sErrorPlace = "Let Database()"
End Property

Public Property Get Database() As String
On Error GoTo errhandler
    Database = sDatabase
    Exit Property
errhandler:
    lErrorNumber = Err.Number
    sErrorDescription = Err.Description
    sErrorPlace = "Get Database()"
End Property

Public Property Let Provider(ByVal inProviderString As String)
On Error GoTo errhandler
    sProviderString = inProviderString
    Exit Property
errhandler:
    lErrorNumber = Err.Number
    sErrorDescription = Err.Description
    sErrorPlace = "Let Provider()"
End Property

Public Property Get Provider() As String
On Error GoTo errhandler
    Provider = sProviderString
    Exit Property
errhandler:
    lErrorNumber = Err.Number
    sErrorDescription = Err.Description
    sErrorPlace = "Get Provider()"
End Property

Public Property Let ODBCString(ByVal inODBCString As String)
On Error GoTo errhandler
    sODBCString = inODBCString
    Exit Property
errhandler:
    lErrorNumber = Err.Number
    sErrorDescription = Err.Description
    sErrorPlace = "Let ODBCString()"
End Property

Public Property Get ODBCString() As String
On Error GoTo errhandler
    ODBCString = sODBCString
    Exit Property
errhandler:
    lErrorNumber = Err.Number
    sErrorDescription = Err.Description
    sErrorPlace = "Get ODBCString()"
End Property

Public Property Let SQLString(ByVal inSQLString As String)
On Error GoTo errhandler
    sSQLString = inSQLString
    oADOCommand.CommandText = sSQLString
    Exit Property
errhandler:
    lErrorNumber = Err.Number
    sErrorDescription = Err.Description
    sErrorPlace = "Let SQLString()"
End Property

Public Property Get SQLString() As String
On Error GoTo errhandler
    SQLString = sSQLString
    Exit Property
errhandler:
    lErrorNumber = Err.Number
    sErrorDescription = Err.Description
    sErrorPlace = "Get SQLString()"
End Property

Public Property Let ADOCommandText(ByVal inText As String)
On Error GoTo errhandler
    oADOCommand.CommandText = inText
    Exit Property
errhandler:
    lErrorNumber = Err.Number
    sErrorDescription = Err.Description
    sErrorPlace = "Let ADOCommandText()"
End Property

Public Property Get ADOCommandText() As String
On Error GoTo errhandler
    ADOCommandText = oADOCommand.CommandText
    Exit Property
errhandler:
    lErrorNumber = Err.Number
    sErrorDescription = Err.Description
    sErrorPlace = "Get ADOCommandText()"
End Property

Public Function SetODBCString(Optional ByVal inDSN As String, Optional ByVal inUserName As String, Optional ByVal inPassword As String, Optional ByVal inDatabase As String) As Boolean
On Error GoTo errhandler
    Dim TheDSN As String
    Dim TheUserName As String
    Dim ThePassword As String
    Dim TheDatabase As String

    SetODBCString = False
    If (inDSN = "") Then
        If (sDSN = "") Then
            Exit Function
        Else
            TheDSN = sDSN
        End If
    Else
        TheDSN = inDSN
    End If
    If (inUserName = "") Then
        If (sUserName = "") Then
            Exit Function
        Else
            TheUserName = sUserName
        End If
    Else
        TheUserName = inUserName
    End If
    If (inPassword = "") Then
        If (sPassword = "") Then
            Exit Function
        Else
            ThePassword = sPassword
        End If
    Else
        ThePassword = inPassword
    End If
    If (inDatabase = "") Then
        If (sDatabase = "") Then
            Exit Function
        Else
            TheDatabase = sDatabase
        End If
    Else
        TheDatabase = inDatabase
    End If
    sODBCString = "DSN=" & TheDSN & ";uid=" & TheUserName & ";pwd=" & ThePassword & ";database=" & TheDatabase
    SetODBCString = True
    Exit Function
errhandler:
    lErrorNumber = Err.Number
    sErrorDescription = Err.Description
    sErrorPlace = "Set SetODBCString()"
    SetODBCString = False
End Function

Public Function GetState() As Integer
On Error GoTo errhandler
    GetState = oDBConnection.State
    Exit Function
errhandler:
    lErrorNumber = Err.Number
    sErrorDescription = Err.Description
    sErrorPlace = "Get State()"
    GetState = lErrorNumber
End Function

Public Function OpenODBCConnection() As Long
On Error GoTo errhandler
    If (ODBCString = "") Then
        OpenODBCConnection = -2
    Else
        oDBConnection.Open sODBCString
        If (oDBConnection.State = 1) Then
            Set oADOCommand.ActiveConnection = oDBConnection
            oDbRecordSet.CursorLocation = adUseClient
            OpenODBCConnection = 0   'OK
        Else
            OpenODBCConnection = -1   'Error
        End If
    End If
    Exit Function
errhandler:
    lErrorNumber = Err.Number
    sErrorDescription = Err.Description
    sErrorPlace = "CRVADOAccess.OpenODBCConnection()"
    OpenODBCConnection = lErrorNumber
End Function

Public Function OpenProviderConnection() As Long
On Error GoTo errhandler
    If (sProviderString = "") Then
        OpenProviderConnection = -2
    Else
        oDBConnection.Open sProviderString
        If (oDBConnection.State = 1) Then
            oDbRecordSet.CursorLocation = adUseClient
            Set oADOCommand.ActiveConnection = oDBConnection
            OpenProviderConnection = 0   'OK
        Else
            OpenProviderConnection = -1   'Error
        End If
    End If
    Exit Function
errhandler:
    lErrorNumber = Err.Number
    sErrorDescription = Err.Description
    sErrorPlace = "CRVADOAccess.OpenProviderConnection()"
    OpenProviderConnection = lErrorNumber
End Function

Public Function SubmitQuery(Optional ByRef inSQLString As String, _
                            Optional ByRef inCursor As String) As Long
On Error GoTo errhandler
    Dim sCursor As String

    If (Len(inCursor) > 0) Then
        sCursor = inCursor
    Else
        sCursor = adOpenForwardOnly
    End If
    'Check if Connected
    If (oDBConnection.State = 0) Then 'Not Connected
        If (ProviderConnection) Then
            lResult = OpenProviderConnection
        Else
            lResult = OpenODBCConnection
        End If
        If (lResult <> 0) Then
            Exit Function
        End If
    End If
    'Check if Record Set Open
    If (oDbRecordSet.State <> 0) Then 'RecordSet is open
        oDbRecordSet.Close
    End If
    'Check if SQL in method call
    If (inSQLString = "") Then
        If (bLogging) Then
            WriteLogRecord oADOCommand.CommandText
        End If
        oDbRecordSet.Open oADOCommand, oDBConnection, sCursor
    Else
        If (bLogging) Then
            WriteLogRecord inSQLString
        End If
        oADOCommand.CommandText = inSQLString
        oDbRecordSet.Open oADOCommand
        'Debug.Print oDbRecordSet.RecordCount
    End If
    SubmitQuery = 0   'Return OK
    Exit Function
errhandler:
    lErrorNumber = Err.Number
    sErrorDescription = Err.Description
    sErrorPlace = "SubmitQuery()"
    If (bLogging) Then
        WriteLogRecord lErrorNumber & " " & sErrorDescription
    End If
    SubmitQuery = lErrorNumber   'Return Error
End Function

Public Function ADOCommandExecute() As Integer
On Error GoTo errhandler
    oADOCommand.Execute
    Exit Function
errhandler:
    lErrorNumber = Err.Number
    sErrorDescription = Err.Description
    sErrorPlace = "ADOCommandExecute()"
End Function

Public Function RetrieveRecordSet() As ADODB.Recordset
On Error GoTo errhandler
    'This function returns a clone of the recordset
    Set RetrieveRecordSet = oDbRecordSet.Clone
Exit Function
errhandler:
    lErrorNumber = Err.Number
    sErrorDescription = Err.Description
    sErrorPlace = "RetrieveRecordSet()"
    Set RetrieveRecordSet = Nothing
End Function

Public Function RetrieveRecordSetPointer() As ADODB.Recordset
On Error GoTo errhandler
    'This function returns a pointer to the recordset
    Set RetrieveRecordSetPointer = oDbRecordSet
Exit Function
errhandler:
    lErrorNumber = Err.Number
    sErrorDescription = Err.Description
    sErrorPlace = "RetrieveRecordSetPointer()"
    Set RetrieveRecordSetPointer = Nothing
End Function

Public Function CloseRecordSet() As Long
On Error GoTo errhandler
    If (oDbRecordSet.State = 1) Then
        oDbRecordSet.Close
    End If
    CloseRecordSet = oDbRecordSet.State
    Exit Function
errhandler:
    lErrorNumber = Err.Number
    sErrorDescription = Err.Description
    sErrorPlace = "CloseConnection()"
End Function

Public Function CloseConnection() As Long
On Error GoTo errhandler
    If (oDBConnection.State = 1) Then
        oDBConnection.Close
        CloseConnection = 0
    Else
        CloseConnection = -1
    End If
    Exit Function
errhandler:
    lErrorNumber = Err.Number
    sErrorDescription = Err.Description
    sErrorPlace = "CloseConnection()"
End Function

Public Function MoveFirst() As Boolean
On Error GoTo errhandler
    oDbRecordSet.MoveFirst
    MoveFirst = True
    Exit Function
errhandler:
    lErrorNumber = Err.Number
    sErrorDescription = Err.Description
    sErrorPlace = "MoveFirst()"
    MoveFirst = False
End Function

Private Sub WriteLogRecord(inSQL As String)
On Error Resume Next

    iLogFileNumber = FreeFile
    'Check if  file already exists
    If (Dir(sLogFilePath) = "") Then
        Open sLogFilePath For Output As #iLogFileNumber
    Else
        Open sLogFilePath For Append As #iLogFileNumber
    End If
         
    'Write out the record
    Print #iLogFileNumber, inSQL

    Close #iLogFileNumber

End Sub