I use ADO (specifically for accessing SQL) daily at work. So, I finally decided that I was going to create a class that makes it simple for myself and other programmers on the job to use. Just the other day, I saw @MathieuGuindon's post about creating parameters on the fly, and I really liked his Idea, so I implemented parts of it on top of some of the stuff that I already had.
As for the code itself, I have really struggled with determining if I am using the appropriate level of abstraction for properties and methods, which is why I am here.
ADODBWrapper
Option Explicit
Private Type TADODBWrapper
ParameterNumericScale As Byte
ParameterPrecision As Byte
ADOErrors As ADODB.Errors
HasADOError As Boolean
End Type
Private this As TADODBWrapper
Public Property Get ParameterNumericScale() As Byte
ParameterNumericScale = this.ParameterNumericScale
End Property
Public Property Let ParameterNumericScale(ByVal valueIn As Byte)
this.ParameterNumericScale = valueIn
End Property
Public Property Get ParameterPrecision() As Byte
ParameterPrecision = this.ParameterPrecision
End Property
Public Property Let ParameterPrecision(ByVal valueIn As Byte)
this.ParameterPrecision = valueIn
End Property
Public Property Get Errors() As ADODB.Errors
Set Errors = this.ADOErrors
End Property
Public Property Get HasADOError() As Boolean
HasADOError = this.HasADOError
End Property
Private Sub Class_Terminate()
With this
.ParameterNumericScale = Empty
.ParameterPrecision = Empty
.HasADOError = Empty
Set .ADOErrors = Nothing
End With
End Sub
Public Function GetRecordSet(ByRef Connection As ADODB.Connection, _
ByVal CommandText As String, _
ByVal CommandType As ADODB.CommandTypeEnum, _
ByVal CursorType As ADODB.CursorTypeEnum, _
ByVal LockType As ADODB.LockTypeEnum, _
ParamArray ParameterValues() As Variant) As ADODB.Recordset
Dim Cmnd As ADODB.Command
ValidateConnection Connection
On Error GoTo CleanFail
Set Cmnd = CreateCommand(Connection, CommandText, CommandType, CVar(ParameterValues)) 'must convert paramarray to
'a variant in order to pass
'to another function
'Note: When used on a client-side Recordset object,
' the CursorType property can be set only to adOpenStatic.
Set GetRecordSet = New ADODB.Recordset
GetRecordSet.CursorType = CursorType
GetRecordSet.LockType = LockType
Set GetRecordSet = Cmnd.Execute(Options:=ExecuteOptionEnum.adAsyncFetch)
CleanExit:
Set Cmnd = Nothing
Exit Function
CleanFail:
PopulateADOErrorObject Connection
Resume CleanExit
End Function
Public Function GetDisconnectedRecordSet(ByRef ConnectionString As String, _
ByVal CursorLocation As ADODB.CursorLocationEnum, _
ByVal CommandText As String, _
ByVal CommandType As ADODB.CommandTypeEnum, _
ParamArray ParameterValues() As Variant) As ADODB.Recordset
Dim Cmnd As ADODB.Command
Dim CurrentConnection As ADODB.Connection
On Error GoTo CleanFail
Set CurrentConnection = CreateConnection(ConnectionString, CursorLocation)
Set Cmnd = CreateCommand(CurrentConnection, CommandText, CommandType, CVar(ParameterValues)) 'must convert paramarray to
'a variant in order to pass
'to another function
Set GetDisconnectedRecordSet = New ADODB.Recordset
With GetDisconnectedRecordSet
.CursorType = adOpenStatic 'Must use this cursortype and this locktype to work with a disconnected recordset
.LockType = adLockBatchOptimistic
.Open Cmnd, , , , adAsyncFetch
'disconnect the recordset
Set .ActiveConnection = Nothing
End With
CleanExit:
Set Cmnd = Nothing
If Not CurrentConnection Is Nothing Then: If CurrentConnection.State > 0 Then CurrentConnection.Close
Set CurrentConnection = Nothing
Exit Function
CleanFail:
PopulateADOErrorObject CurrentConnection
Resume CleanExit
End Function
Public Function QuickExecuteNonQuery(ByVal ConnectionString As String, _
ByVal CommandText As String, _
ByVal CommandType As ADODB.CommandTypeEnum, _
ByRef RecordsAffectedReturnVal As Long, _
ParamArray ParameterValues() As Variant) As Boolean
Dim Cmnd As ADODB.Command
Dim CurrentConnection As ADODB.Connection
On Error GoTo CleanFail
Set CurrentConnection = CreateConnection(ConnectionString, adUseServer)
Set Cmnd = CreateCommand(CurrentConnection, CommandText, CommandType, CVar(ParameterValues)) 'must convert paramarray to
'a variant in order to pass
'to another function
Cmnd.Execute RecordsAffected:=RecordsAffectedReturnVal, Options:=ExecuteOptionEnum.adExecuteNoRecords
QuickExecuteNonQuery = True
CleanExit:
Set Cmnd = Nothing
If Not CurrentConnection Is Nothing Then: If CurrentConnection.State > 0 Then CurrentConnection.Close
Set CurrentConnection = Nothing
Exit Function
CleanFail:
PopulateADOErrorObject CurrentConnection
Resume CleanExit
End Function
Public Function ExecuteNonQuery(ByRef Connection As ADODB.Connection, _
ByVal CommandText As String, _
ByVal CommandType As ADODB.CommandTypeEnum, _
ByRef RecordsAffectedReturnVal As Long, _
ParamArray ParameterValues() As Variant) As Boolean
Dim Cmnd As ADODB.Command
ValidateConnection Connection
On Error GoTo CleanFail
Set Cmnd = CreateCommand(Connection, CommandText, CommandType, CVar(ParameterValues)) 'must convert paramarray to
'a variant in order to pass
'to another function
Cmnd.Execute RecordsAffected:=RecordsAffectedReturnVal, Options:=ExecuteOptionEnum.adExecuteNoRecords
ExecuteNonQuery = True
CleanExit:
Set Cmnd = Nothing
Exit Function
CleanFail:
PopulateADOErrorObject Connection
Resume CleanExit
End Function
Public Function CreateConnection(ByRef ConnectionString As String, ByVal CursorLocation As ADODB.CursorLocationEnum) As ADODB.Connection
On Error GoTo CleanFail
Set CreateConnection = New ADODB.Connection
CreateConnection.CursorLocation = CursorLocation
CreateConnection.Open ConnectionString
CleanExit:
Exit Function
CleanFail:
PopulateADOErrorObject CreateConnection
Resume CleanExit
End Function
Private Function CreateCommand(ByRef Connection As ADODB.Connection, _
ByVal CommandText As String, _
ByVal CommandType As ADODB.CommandTypeEnum, _
ByRef ParameterValues As Variant) As ADODB.Command
Set CreateCommand = New ADODB.Command
With CreateCommand
.ActiveConnection = Connection
.CommandText = CommandText
.Prepared = True
.CommandTimeout = 0
AppendParameters CreateCommand, ParameterValues
.CommandType = CommandType
End With
End Function
Private Sub AppendParameters(ByRef Command As ADODB.Command, ByRef ParameterValues As Variant)
Dim i As Long
Dim ParamVal As Variant
If UBound(ParameterValues) = -1 Then Exit Sub 'not allocated
For i = LBound(ParameterValues) To UBound(ParameterValues)
ParamVal = ParameterValues(i)
Command.Parameters.Append ToADOInputParameter(ParamVal)
Next i
End Sub
Private Function ToADOInputParameter(ByVal ParameterValue As Variant) As ADODB.Parameter
Dim ResultParameter As New ADODB.Parameter
If Me.ParameterNumericScale = 0 Then Me.ParameterNumericScale = 10
If Me.ParameterPrecision = 0 Then Me.ParameterPrecision = 2
With ResultParameter
Select Case VarType(ParameterValue)
Case vbInteger
.Type = adInteger
Case vbLong
.Type = adInteger
Case vbSingle
.Type = adSingle
.Precision = Me.ParameterPrecision
.NumericScale = Me.ParameterNumericScale
Case vbDouble
.Type = adDouble
.Precision = Me.ParameterPrecision
.NumericScale = Me.ParameterNumericScale
Case vbDate
.Type = adDate
Case vbCurrency
.Type = adCurrency
.Precision = Me.ParameterPrecision
.NumericScale = Me.ParameterNumericScale
Case vbString
.Type = adVarChar
.Size = Len(ParameterValue)
Case vbBoolean
.Type = adBoolean
End Select
.Direction = ADODB.ParameterDirectionEnum.adParamInput
.value = ParameterValue
End With
Set ToADOInputParameter = ResultParameter
End Function
Private Sub ValidateConnection(ByRef Connection As ADODB.Connection)
If Connection.Errors.Count = 0 Then Exit Sub
If Not this.HasADOError Then PopulateADOErrorObject Connection
Dim ADOError As ADODB.Error
Set ADOError = GetError(Connection.Errors, Connection.Errors.Count - 1) 'Note: 0 based collection
Err.Raise ADOError.Number, ADOError.Source, ADOError.Description, ADOError.HelpFile, ADOError.HelpContext
End Sub
Private Sub PopulateADOErrorObject(ByRef Connection As ADODB.Connection)
If Connection.Errors.Count = 0 Then Exit Sub
this.HasADOError = True
Set this.ADOErrors = Connection.Errors
End Sub
Public Function ErrorsToString() As String
Dim ADOError As ADODB.Error
Dim i As Long
Dim ErrorMsg As String
For Each ADOError In this.ADOErrors
i = i + 1
With ADOError
ErrorMsg = ErrorMsg & "Count: " & vbTab & i & vbNewLine
ErrorMsg = ErrorMsg & "ADO Error Number: " & vbTab & CStr(.Number) & vbNewLine
ErrorMsg = ErrorMsg & "Description: " & vbTab & .Description & vbNewLine
ErrorMsg = ErrorMsg & "Source: " & vbTab & .Source & vbNewLine
ErrorMsg = ErrorMsg & "NativeError: " & vbTab & CStr(.NativeError) & vbNewLine
ErrorMsg = ErrorMsg & "HelpFile: " & vbTab & .HelpFile & vbNewLine
ErrorMsg = ErrorMsg & "HelpContext: " & vbTab & CStr(.HelpContext) & vbNewLine
ErrorMsg = ErrorMsg & "SQLState: " & vbTab & .SqlState & vbNewLine
End With
Next
ErrorsToString = ErrorMsg
End Function
Public Function GetError(ByRef ADOErrors As ADODB.Errors, ByVal Index As Variant) As ADODB.Error
Set GetError = ADOErrors.Item(Index)
End Function
I provide two methods for returning a recordset:
GetRecordSet: The client code owns theConnectionobject so cleanup should be managed by them.GetDisconnectedRecordset: this method owns and manages theConnectionobject itself.
And Two Methods for Executing a Command that does not return an records:
ExecuteNonQuery: Just as inGetRecordSet, the client owns and manages the connection.QuickExecuteNonQuery: Just as was done in this post, I used the "Quick" prefix to refer to an "overload" method that owns its own connection.
The Properties ParameterNumericScale and ParameterPrecision are used for setting the total number of digits and number of digits to the right of the decimal point in a number respectively. I opted to make these Properties instead of passing them as function parameters to either of GetRecordSet, GetDisconnectedRecordset, ExecuteNonQuery, or QuickExecuteNonQuery, because I felt that it was far too cluttered otherwise.
The Errors property exposes the ADODB.Errors collection which is available only through the Connection object, without actually exposing the connection itself. The reason for this is that depending on the method used in the client code, the Connection may or may not be available to the client...also, it would just be a bad idea all around to have a globally available Connection object. Saying that, if an error occurs that does not populate VBA runtime's native Err object, then I am populating the the Error property in the class with any the errors found in the Connnection.Errors collection, so that I can use return useful error information to the client code.
CreateCommand creates an AADODB.Command object and uses ApendParameters with ToADOInputParameter to create ADODB.Parameter objects on the fly by interpreting the datatype passed in to the ParameterValues array and generating the equivalent ADODB datatype to pass to the database.
Usage:
Sub TestingSQLQueryText()
Dim SQLDataAdapter As ADODBWrapper
Dim Conn As ADODB.Connection
Dim rsConnected As ADODB.Recordset
Set SQLDataAdapter = New ADODBWrapper
On Error GoTo CleanFail
Set Conn = SQLDataAdapter.CreateConnection(CONN_STRING, adUseClient)
Set rsConnected = SQLDataAdapter.GetRecordSet(Conn, "Select * From SOME_TABLE Where SOME_FIELD=?", _
adCmdText, adOpenStatic, adLockReadOnly, "1361")
FieldNamesToRange rsConnected, Sheet1.Range("A1")
rsConnected.Filter = "[SOME_FIELD]='215485'"
Debug.Print rsConnected.RecordCount
Sheet1.Range("A2").CopyFromRecordset rsConnected
Conn.Close
Set Conn = Nothing
'***********************************************************************************************
Dim rsDisConnected As ADODB.Recordset
Set rsDisConnected = SQLDataAdapter.GetDisconnectedRecordSet(CONN_STRING, adUseClient, _
"Select * From SOME_TABLE Where SOME_FIELD=?", _
adCmdText, "1361")
FieldNamesToRange rsDisConnected, Sheet2.Range("A1")
rsDisConnected.Filter = "[SOME_FIELD]='215485'"
Debug.Print rsDisConnected.RecordCount
Sheet2.Range("A2").CopyFromRecordset rsDisConnected
CleanExit:
If Not Conn Is Nothing Then: If Conn.State > 0 Then Conn.Close
Set Conn = Nothing
Exit Sub
CleanFail:
If SQLDataAdapter.HasADOError Then Debug.Print SQLDataAdapter.ErrorsToString()
Resume CleanExit
End Sub
Sub TestingStoredProcedures()
Dim SQLDataAdapter As ADODBWrapper
Dim Conn As ADODB.Connection
Dim rsConnected As ADODB.Recordset
Set SQLDataAdapter = New ADODBWrapper
On Error GoTo CleanFail
Set Conn = SQLDataAdapter.CreateConnection(CONN_STRING, adUseClient)
Set rsConnected = SQLDataAdapter.GetRecordSet(Conn, "SOME_STORED_PROC", _
adCmdStoredProc, adOpenStatic, adLockReadOnly, "1361,476")
FieldNamesToRange rsConnected, Sheet1.Range("A1")
rsConnected.Filter = "[SOME_FIELD]='1361'"
Debug.Print rsConnected.RecordCount
Sheet1.Range("A2").CopyFromRecordset rsConnected
Conn.Close
Set Conn = Nothing
'***********************************************************************************************
Dim rsDisConnected As ADODB.Recordset
Set rsDisConnected = SQLDataAdapter.GetDisconnectedRecordSet(CONN_STRING, adUseClient, _
"SOME_STORED_PROC", _
adCmdStoredProc, "1361,476")
FieldNamesToRange rsDisConnected, Sheet2.Range("A1")
rsDisConnected.Filter = "[SOME_FIELD]='1361'"
Debug.Print rsDisConnected.RecordCount
Sheet2.Range("A2").CopyFromRecordset rsDisConnected
CleanExit:
If Not Conn Is Nothing Then: If Conn.State > 0 Then Conn.Close
Set Conn = Nothing
Exit Sub
CleanFail:
If SQLDataAdapter.HasADOError Then Debug.Print SQLDataAdapter.ErrorsToString()
Resume CleanExit
End Sub
Sub TestingNonQuery()
Dim SQLDataAdapter As ADODBWrapper
Dim Conn As ADODB.Connection
Dim RecordsUpdated1 As Long
Set SQLDataAdapter = New ADODBWrapper
On Error GoTo CleanFail
Set Conn = SQLDataAdapter.CreateConnection(CONN_STRING, adUseClient)
If SQLDataAdapter.ExecuteNonQuery(Conn, "Update SOME_TABLE Where SOME_FIELD = ?", _
adCmdText, RecordsUpdated, "2") Then Debug.Print RecordsUpdated
'***********************************************************************************************
Dim RecordsUpdated2 As Long
If SQLDataAdapter.QuickExecuteNonQuery(CONN_STRING, "SOME_STORED_PROC", _
adCmdStoredProc, "1361, 476") Then Debug.Print RecordsUpdated2
CleanExit:
If Not Conn Is Nothing Then: If Conn.State > 0 Then Conn.Close
Set Conn = Nothing
Exit Sub
CleanFail:
If SQLDataAdapter.HasADOError Then Debug.Print SQLDataAdapter.ErrorsToString()
Resume CleanExit
End Sub
