2
\$\begingroup\$

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

"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
\$\endgroup\$
  • 1
    \$\begingroup\$ 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. \$\endgroup\$ – Mathieu Guindon Sep 17 at 23:04
  • 1
    \$\begingroup\$ TIL about Parameters.Refresh - thanks for this post! \$\endgroup\$ – Mathieu Guindon Sep 17 at 23:06
  • \$\begingroup\$ @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. \$\endgroup\$ – rickmanalexander Sep 18 at 19:28

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.