ADODB Wrapper Class (Revisited)

Question

I recently posted this question on my implementation of an ADODB Wrapper Class. I realized in my own review that I was missing some very important things, so much so, that I decided it would be worth it to re-write the entire class. Saying that I have done quite a bit of restructuring so I am going to provide an outline of what I have done and why.

Numeric Parameters:

I removed the public properties ParameterNumericScale and ParameterPrecision as I was not considering the possibility of a parameters with varying precision and numericscale. To address this, I created 2 functions that automatically calculate the precision and numericscale 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

ADO Connection Error's Collection:

I opted to pass the Connection.Errors collection alone, instead of the entire Connection Object to each of the sub procedures ValidateConnection and PopulateADOErrorObject:

Private Sub ValidateConnection(ByVal 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

Bi-Directional Parameters:

Previously, I was only considering the use of Input Parameters for a given command, because there is no way to know what Direction a parameter should be mapped. However, I was able to come up with something close to this, by implicitly calling the Parameters.Refresh method of the Parameters collection object. Note that Parameters STILL have to be passed in the correct order or ADO will populate the Connection.Errors collection. It is also worth mentioning that this has a very small (virtually unnoticeable) performance hit, but even still, I chose to leave it up to the client to choose which method that they want use. I did so by adding a boolean property called DeriveParameterDirection, which If set to true, then the DerivedDirectionParameters implementation of the IADODBParametersWrapper will be used, in the private CreateCommand procedure. If false, then the AssumeParameterDirection of IADODBParametersWrapper will be used.

Also, If output parameters are used, you need a way to return them, so I use the following in ADODBWrapper to do so:

'note: this.OuputParameters is a read only property at the class level
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

IADODBParametersWrapper (Interface):

Option Explicit
Public Sub SetParameters(ByRef Command As ADODB.Command, ByRef ParameterValues As Variant)
End Sub
Private Sub Class_Initialize()
 Err.Raise vbObjectError + 1024, TypeName(Me), "An Interface class must not be instantiated."
End Sub

AssumedDirectionParameters (Class):

Option Explicit
Implements IADODBParametersWrapper
Private Sub IADODBParametersWrapper_SetParameters(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
 With ResultParameter
 Select Case VarType(ParameterValue)
 Case vbInteger
 .Type = adInteger
 Case vbLong
 .Type = adInteger
 Case vbSingle
 .Type = adSingle
 .Precision = CalculatePrecision(ParameterValue)
 .NumericScale = CalculateNumericScale(ParameterValue)
 Case vbDouble
 .Type = adDouble
 .Precision = CalculatePrecision(ParameterValue)
 .NumericScale = CalculateNumericScale(ParameterValue)
 Case vbDate
 .Type = adDate
 Case vbCurrency
 .Type = adCurrency
 .Precision = CalculatePrecision(ParameterValue)
 .NumericScale = CalculateNumericScale(ParameterValue)
 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 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

DerivedDirectionParameters (Class):

Option Explicit
Implements IADODBParametersWrapper
Private Sub IADODBParametersWrapper_SetParameters(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 '.Parameters(i + 1) b/c of @RETURN_VALUE
 'mentioned above
 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
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

ADODBWrapper (Class):

Option Explicit
Private Type TADODBWrapper
 DeriveParameterDirection As Boolean
 CommandTimeout As Long
 OuputParameters As Collection
 ADOErrors As ADODB.Errors
 HasADOError As Boolean
End Type
Private this As TADODBWrapper
Public Property Get DeriveParameterDirection() As Boolean
 DeriveParameterDirection = this.DeriveParameterDirection
End Property
Public Property Let DeriveParameterDirection(ByVal value As Boolean)
 this.DeriveParameterDirection = value
End Property
Public Property Get CommandTimeout() As Long
 CommandTimeout = this.CommandTimeout
End Property
Public Property Let CommandTimeout(ByVal value As Long)
 this.CommandTimeout = value
End Property
Public Property Get OuputParameters() As Collection
 Set OuputParameters = this.OuputParameters
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
 .CommandTimeout = Empty
 .DeriveParameterDirection = Empty
 Set .OuputParameters = Nothing
 Set .ADOErrors = Nothing
 .HasADOError = Empty
 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.Errors
 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)
 'if successful
 If Not this.ADOErrors Is Nothing Then this.ADOErrors.Clear
CleanExit:
 Set Cmnd = Nothing
 Exit Function
CleanFail:
 PopulateADOErrorObject Connection.Errors
 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, , , , Options:=ExecuteOptionEnum.adAsyncFetch
 'disconnect the recordset
 Set .ActiveConnection = Nothing
 End With
 'if successful
 If Not this.ADOErrors Is Nothing Then this.ADOErrors.Clear
CleanExit:
 Set Cmnd = Nothing
 If Not CurrentConnection Is Nothing Then: If (CurrentConnection.State And adStateOpen) = adStateOpen Then CurrentConnection.Close
 Set CurrentConnection = Nothing
 Exit Function
CleanFail:
 PopulateADOErrorObject CurrentConnection.Errors
 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
 'if successful
 If Not this.ADOErrors Is Nothing Then this.ADOErrors.Clear
CleanExit:
 Set Cmnd = Nothing
 If Not CurrentConnection Is Nothing Then: If (CurrentConnection.State And adStateOpen) = adStateOpen Then CurrentConnection.Close
 Set CurrentConnection = Nothing
 Exit Function
CleanFail:
 PopulateADOErrorObject CurrentConnection.Errors
 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.Errors
 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
 'if successful
 If Not this.ADOErrors Is Nothing Then this.ADOErrors.Clear
CleanExit:
 Set Cmnd = Nothing
 Exit Function
CleanFail:
 PopulateADOErrorObject Connection.Errors
 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.Errors
 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
 Dim ParameterGenerator As IADODBParametersWrapper
 Set CreateCommand = New ADODB.Command
 With CreateCommand
 .ActiveConnection = Connection
 .CommandText = CommandText
 .CommandTimeout = Me.CommandTimeout '0
 End With
 If Me.DeriveParameterDirection Then
 Set ParameterGenerator = New DerivedDirectionParameters
 CreateCommand.CommandType = CommandType 'When set before accessing the Parameters Collection,
 'Parameters.Refresh is impilicitly called
 ParameterGenerator.SetParameters CreateCommand, ParameterValues
 PopulateOutPutParameters CreateCommand.Parameters
 Else
 Set ParameterGenerator = New AssumedDirectionParameters
 ParameterGenerator.SetParameters CreateCommand, ParameterValues
 CreateCommand.CommandType = CommandType
 End If
End Function
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
Private Sub PopulateADOErrorObject(ByVal ConnectionErrors As ADODB.Errors)
 If ConnectionErrors.Count = 0 Then Exit Sub
 this.HasADOError = True
 Set this.ADOErrors = ConnectionErrors
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 & vbNewLine
End Function
Public Function GetError(ByRef ADOErrors As ADODB.Errors, ByVal Index As Variant) As ADODB.Error
 Set GetError = ADOErrors.item(Index)
End Function
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

Answer 1

CommandTimeout:

Allowing the client to specify a given command's execution time threshold by making it a read/write property is good improvement from the first post of this class, that you did not mention in your "outline of what I have done and why", so I am mentioning it here.

Public Property Get CommandTimeout() As Long
 CommandTimeout = this.CommandTimeout
End Property
Public Property Let CommandTimeout(ByVal value As Long)
 this.CommandTimeout = value
End Property

Managing The Connection Object:

Since I am on the topic of things you forgot to mention, In both of GetDisconnectedRecordset and QuickExecuteNonQuery, you wrote this:

If Not CurrentConnection Is Nothing Then: If (CurrentConnection.State And adStateOpen) = adStateOpen Then CurrentConnection.Close
Set CurrentConnection = Nothing

Bit-wise comparisons, specifically with respect to the Connection object's state, is good, but you could probably make the code look more friendly:

If Not CurrentConnection Is Nothing Then
 If (CurrentConnection.State And adStateOpen) = adStateOpen Then
 CurrentConnection.Close
 End If
End If
Set CurrentConnection = Nothing 

OutPut Parameters:

"Also, If output parameters are used, you need a way to return them, so I use the following in ADODBWrapper to do so"

You are indeed able to return parameters, from your OuputParameters property, in the sense that you are returning the ACTual Parameter object, but why do that if you only want to access a parameter's value? As you have it now, one would have to write code like the following, just to get a value:

Private Sub GetOutputParams()
 Dim SQLDataAdapter As ADODBWrapper
 Dim rsDisConnected As ADODB.Recordset
 Dim InputParam As String
 Dim OutPutParam As Integer
 Set SQLDataAdapter = New ADODBWrapper
 SQLDataAdapter.DeriveParameterDirection = True
 On Error GoTo CleanFail
 InputParam = "Val1,Val2,Val3"
 Set rsDisConnected = SQLDataAdapter.GetDisconnectedRecordSet(CONN_STRING, adUseClient, _
 "SCHEMA.SOME_STORED_PROC_NAME", _
 adCmdStoredProc, InputParam, OutPutParam)
 Sheet1.Range("A2").CopyFromRecordset rsDisConnected
 '***************************************************
 'set the parameter object only to return the value? 
 Dim Param As ADODB.Parameter 
 If SQLDataAdapter.OuputParameters.Count > 0 Then 
 Set Param = SQLDataAdapter.OuputParameters(1)
 Debug.Print Param.Value
 End If
 '***************************************************
CleanExit:
 Exit Sub
CleanFail:
 If SQLDataAdapter.HasADOError Then Debug.Print SQLDataAdapter.ErrorsToString()
 Resume CleanExit
End Sub

If you change the private PopulateOutPutParameters procedure In ADODBWrapper to add only the Parameter.Value to OutPutParameters collection like this:

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.value
 Case adParamOutput
 this.OuputParameters.Add Param.value
 Case adParamReturnValue
 this.OuputParameters.Add Param.value
 End Select
 Next
End Sub

Then you could do this in the client code:

If SQLDataAdapter.OuputParameters.Count > 0 Then
 Debug.Print SQLDataAdapter.OuputParameters(1)
End If

Saying all of that, it would still be nice to have a way to map parameters without the client having to know their ordinal position as determined by the way a stored procedure was written, but this is much easier said than done.