ADODB Wrapper Class

Question

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:

1. GetRecordSet: The client code owns the Connection object so cleanup should be managed by them.
2. GetDisconnectedRecordset: this method owns and manages the Connection object itself.

And Two Methods for Executing a Command that does not return an records:

1. ExecuteNonQuery: Just as in GetRecordSet, the client owns and manages the connection.
2. 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

Answer 1

"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."

Consider the case where there are several numeric parameters being passed in, each with varying precision and numericscale. Setting a property at the class level generalizes the NumericScale and Precision for parameters passed which is quite limiting. The way around this would be to create 2 functions that automatically calculate this for each parameter passed in:

Private Function CalculatePrecision(ByVal Value As Variant) As Byte
 CalculatePrecision = CByte(Len(Replace(CStr(Value), ".", vbNullString)))
End Function
Private Function CalculateNumericScale(ByVal Value As Variant) As Byte
 CalculateNumericScale = CByte(Len(Split(CStr(Value), ".")(1)))
End Function

Regarding a Connection's Error Collection, If you are only interested in the collection itself, then why not pass IT, instead of the entire Connection Object to ValidateConnection and PopulateADOErrorObject:

Private Sub ValidateConnection(ByRef ConnectionErrors As ADODB.Errors)
 If ConnectionErrors.Count > 0 Then
 If Not this.HasADOError Then PopulateADOErrorObject ConnectionErrors
 Dim ADOError As ADODB.Error
 Set ADOError = GetError(ConnectionErrors, ConnectionErrors.Count - 1) 'Note: 0 based collection
 Err.Raise ADOError.Number, ADOError.Source, ADOError.Description, ADOError.HelpFile, ADOError.HelpContext
 End If
End Sub

Lastly, you are only allowing the use of Input Parameters. Consider the case where a stored procedure has InPut, OutPut, InputOutput, or ReturnValue parameters.

The way the code is written now, an error would be thrown. The challenge in addressing this is that there is no way to know what Direction a parameter should be mapped, unless you were to implement some sort of class to create named parameters and use string interpolation to allow parameter specific mapping.

Saying that, there is an alternative method that allows something close to the above that is provided in the ADODB library already, i.e. the Parameters.Refresh method.

It is worth mentioning however, that this would cause an ever so slight performance decrease, but this will likely be unnoticeable Microsoft mentions that using the Parameters.Refresh method of the Parameters collection to retrieve information from the provider, is a potentially resource-intensive operation.

I have found that implicitly calling Parameters.Refresh, as mentioned here is the best way to go:

The link says the following:

You don't even have to use the Refresh method if you don't want to, and using it might even cause ADO to execute an extra round-trip. When you try to read a property of an uninitialized Command.Parameters collection for the first time, ADO constructs the Parameters collection for you—just as if you had executed the Refresh method.

As long as parameters are specified in the correct order, you could change CreateCommand and the methods called by it as follows:

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
 .CommandType = CommandType 'if set here, Parameters.Refresh is impilicitly called
 .CommandTimeout = 0
 SetParameterValues CreateCommand, ParameterValues
 End With
End Function
'AppendParameters ==> SetParameterValues 
Private Sub SetParameterValues(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
 With Command
 If .Parameters.Count = 0 Then
 Err.Raise vbObjectError + 1024, TypeName(Me), "This Provider does " & _
 "not support parameter retrieval."
 End If
 Select Case .CommandType
 Case adCmdStoredProc
 If .Parameters.Count > 1 Then 'Debug.Print Cmnd.Parameters.Count prints 1 b/c it includes '@RETURN_VALUE'
 'which is a default value
 For i = LBound(ParameterValues) To UBound(ParameterValues)
 ParamVal = ParameterValues(i)
 'Explicitly set size to prevent error
 'as per the Note at: https://docs.microsoft.com/en-us/sql/ado/reference/ado-api/refresh-method-ado?view=sql-server-2017
 SetVariableLengthProperties .Parameters(i + 1), ParamVal
 .Parameters(i + 1).Value = ParamVal
 Next i
 End If
 Case adCmdText
 For i = LBound(ParameterValues) To UBound(ParameterValues)
 ParamVal = ParameterValues(i)
 'Explicitly set size to prevent error
 SetVariableLengthProperties .Parameters(i), ParamVal
 .Parameters(i).Value = ParamVal
 Next i
 End Select
 End With
End Sub
Private Sub SetVariableLengthProperties(ByRef Parameter As ADODB.Parameter, ByRef ParameterValue As Variant)
 With Parameter
 Select Case VarType(ParameterValue)
 Case vbSingle
 .Precision = CalculatePrecision(ParameterValue)
 .NumericScale = CalculateNumericScale(ParameterValue)
 Case vbDouble
 .Precision = CalculatePrecision(ParameterValue)
 .NumericScale = CalculateNumericScale(ParameterValue)
 Case vbCurrency
 .Precision = CalculatePrecision(ParameterValue)
 .NumericScale = CalculateNumericScale(ParameterValue)
 Case vbString
 .Size = Len(ParameterValue)
 End Select
 End With
End Sub

You could then add a property that will expose the Command object's OutPut/InputOutput/ReturnValue parameters to the client code like so:

Public Property Get OuputParameters() As Collection
 Set OuputParameters = this.OuputParameters
End Property
Private Sub PopulateOutPutParameters(ByRef Parameters As ADODB.Parameters)
 Dim Param As ADODB.Parameter
 Set this.OuputParameters = New Collection
 For Each Param In Parameters
 Select Case Param.Direction
 Case adParamInputOutput
 this.OuputParameters.Add Param
 Case adParamOutput
 this.OuputParameters.Add Param
 Case adParamReturnValue
 this.OuputParameters.Add Param
 End Select
 Next
End Sub

• Mathieu Guindon: that there is no way to know what Direction a parameter should be mapped - very good point. Could be a good reason to make an OutParameter class; with a factory method on the default instance, call sites would make the nature of the parameter very explicit: OutParameter.Create(foo) (and then either infer the other metadata from the value like the others, or have optional parameters to supply it.. e.g. numScale and numPrecision) - optionally, have a similar factory for "in" parameters, ....or take an enum value for the direction.
• Mathieu Guindon: TIL about Parameters.Refresh - thanks for this post!
• ARickman: @MathieuGuindon Indeed and Thank you Matt! There some other things that I missed in my review, so much so that I chose to rewrite and restructure the entire class. I plan on posting that ASAP.