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
