4
\$\begingroup\$

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
\$\endgroup\$
1
\$\begingroup\$

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.

\$\endgroup\$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.