文章/答案/技术大牛

发布

问ADODB包装类
EN

Code Review用户

提问于 2019-09-11 19:01:00

回答 1查看 446关注 0票数 2

我每天工作时使用ADO (特别是用于访问SQL)。所以，我最终决定，我要创建一个类，让我自己和其他在工作中的程序员能够简单地使用它。就在前几天，我看到@MathieuGuindon关于动态创建参数的帖子，我非常喜欢他的想法，所以我在我已经拥有的一些东西的基础上实现了它的部分内容。

至于代码本身，我真的很难确定我是否对属性和方法使用了适当的抽象级别，这就是我在这里的原因。

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

我提供了两种返回记录集的方法：

GetRecordSet：客户端代码拥有Connection对象，因此清理应该由它们来管理。
GetDisconnectedRecordset：此方法拥有并管理Connection对象本身。

以及执行不返回记录的命令的两种方法：

ExecuteNonQuery：就像在GetRecordSet中一样，客户端拥有和管理连接。
QuickExecuteNonQuery：正如在这 post中所做的那样，我使用“快速”前缀来引用拥有自己的连接的“重载”方法。

属性ParameterNumericScale和ParameterPrecision分别用于将小数点右侧的数字总数和数字数设置为数字。我选择制作这些属性，而不是将它们作为函数参数传递给GetRecordSet、GetDisconnectedRecordset、ExecuteNonQuery或QuickExecuteNonQuery中的任何一个，因为我觉得否则就太混乱了。

Errors属性公开仅通过Connection对象可用的ADODB.Errors集合，而不实际公开连接本身。这样做的原因是，根据客户机代码中使用的方法，连接可能对client...also可用，也可能不可用，因此拥有一个全局可用的Connection对象是个坏主意。如果发生错误而不填充VBA运行时的本机Err对象，则使用在Connnection.Errors集合中发现的任何错误填充类中的Error属性，以便向客户端代码使用有用的错误信息。

CreateCommand创建一个AADODB.Command对象，并通过解释传递给ParameterValues数组的数据类型并生成传递给数据库的等效ADODB数据类型，使用ApendParameters和ToADOInputParameter动态创建ADODB.Parameter对象。

使用：

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

sql

vba

vb6

adodb

回答 1

Code Review用户

回答已采纳

发布于 2019-09-17 15:55:24

“Properties ParameterNumericScale和ParameterPrecision用于将数字中小数点右侧的数字总数和数字数分别设置为小数点的右边。我选择将这些属性作为函数参数传递给GetRecordSet、GetDisconnectedRecordset、ExecuteNonQuery或QuickExecuteNonQuery中的任何一个，因为我觉得否则就太混乱了。”

考虑有几个数字参数正在传递的情况，每个参数具有不同的精度和数字比例尺。在类级别设置属性可以泛化传递参数的NumericScale和Precision，这是非常有限的。这样做的方法是创建两个函数，为传入的每个参数自动计算这个值：

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

关于Connection's Error Collection，如果您只对集合本身感兴趣，那么为什么不传递它，而不是将整个Connection对象传递给ValidateConnection和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

最后，您只允许使用Input参数。考虑存储过程具有InPut, OutPut, InputOutput, or ReturnValue参数的情况。

按照现在编写代码的方式，会引发错误。解决这一问题的挑战是，除非您实现某种类来创建命名参数并使用字符串内插来允许参数特定映射，否则无法知道参数应该映射到哪个方向。

说到这一点，还有一种替代方法，允许在ADODB库中提供接近上述内容的东西，即Parameters.Refresh方法。

然而，值得一提的是，这将导致性能的轻微下降，但这可能是不明显的，微软提到使用参数集合的Parameters.Refresh方法从提供程序检索信息是一种潜在的资源密集型操作。

我发现隐式调用Parameters.Refresh (正如前面提到的这里 )是最好的方法：

链接内容如下：

如果不愿意，甚至不必使用Refresh方法，而且使用它甚至可能导致ADO执行额外的往返。当您第一次尝试读取未初始化的Command.Parameters集合的属性时，ADO将为您构造参数集合--就像您已经执行了Refresh方法一样。

只要以正确的顺序指定了参数，就可以按如下方式更改CreateCommand及其调用的方法：

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

然后，可以添加一个属性，该属性将向客户端代码公开Command对象的输出/InputOutput/ReturnValue参数，如下所示：

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

票数 2

页面原文内容由Code Review提供。腾讯云小微IT领域专用引擎提供翻译支持

原文链接：

https://codereview.stackexchange.com/questions/228864

复制

相似问题

问ADODB包装类
EN

ADODBWrapper

使用：

回答 1

Code Review用户

社区

活动

圈层

关于

腾讯云开发者

热门产品

热门推荐

更多推荐

问ADODB包装类EN

ADODBWrapper

使用：

回答 1

Code Review用户

社区

活动

圈层

关于

腾讯云开发者

热门产品

热门推荐

更多推荐

问ADODB包装类
EN