Private Data Object

Option Compare Binary
Option Explicit

'   Dim PDO As DataObject, PDO2 As Object, PDO3 As Object, Results As Object, _
'       Item As Variant
'
'   Set PDO = New DataObject
'
'   With PDO
'       .Query = "SELECT n.* FROM tblName n WHERE n.FieldName = :ParameterName, "
'       .Bind ":ParameterName", "ParameterValue"
'       .Bind ":ParameterName", "ParameterValue"
'
'        If .Execute Then Debug.Print .RecordCount
'   End With
'
'   Set PDO2 = New DataObject
'
'   With PDO2
'
'        .SetConnection "Provider=Microsoft.ACE.OLEDB.12.0;" _
'            & "Data Source=*;" _
'            & "Persist Security Info=False;"
'
'        .Query = "INSERT INTO tblName (FieldName, ) VALUES (:FieldValue, )"
'        .Query = "UPDATE tblName n SET n.FieldName = :FieldValue,  WHERE n."
'        .Bind ":FieldValue", "FieldValue"
'        .Bind ":FieldValue", "FieldValue"
'
'        .BeginTransaction
'
'        If Not .Execute Then
'            .RollbackTransaction
'        Else
'            .CommitTransaction
'
'            If VBA.Conversion.CBool(.AffectedRows) Then _
                Debug.Print "Inserted or updated"
'        End If
'   End With
'
'   Set PDO3 = New DataObject
'
'   With PDO3
'        Access>File>Options>Client Settings>Advanced>Use Legacy Encryption
'        .SetConnection "Provider=Microsoft.ACE.OLEDB.12.0;" _
'            & "Data Source=*;" _
'            & "Jet OLEDB:Database Password=*;"
'
'        .Query = "SELECT n.* FROM tblName n WHERE n.FieldName = :ParameterName"
'        .Bind ":ParameterName", "ParameterValue"
'        .Bind ":ParameterName", "ParameterValue"
'
'        Set Results = .ResultSet
'
'        If (1 = Results.Count) Then
'            Debug.Print Results("SomeFieldName")
'        Else
'            For Each Item In Results
'               Debug.Print Results(Item)("SomeFieldName")
'            Next Item
'        End If
'    End With
'
'    Set Results = Nothing
'    Set PDO = Nothing
'    Set PDO2 = Nothing
'    Set PDO3 = Nothing

Private pModuleName As String, pConnection As Object, pQuery As String, _
    pParameters As Object, pRecords As Object, pAffectedRows As Long, _
    pRecordCount As Long, pTransactionStarted As Boolean, pClosable As Boolean

Private Sub Class_Initialize()

    pModuleName = Application.VBE.ActiveCodePane.CodeModule.Name

    If ("Microsoft Access" = Application.Name) Then _
        Set pConnection = Application.CurrentProject.Connection
'        SetConnection ""
    Else
'        SetConnection ""
    End If

    Set pParameters = VBA.Interaction.CreateObject("Scripting.Dictionary")

End Sub

Private Sub Class_Terminate()

    If pClosable Then pConnection.Close
    Set pRecords = Nothing
    Set pConnection = Nothing
    Set pParameters = Nothing

End Sub

Public Property Get Query() As String

    Query = pQuery

End Property

Public Property Let Query(ByVal NewValue As String)

    pQuery = NewValue

End Property

Public Property Get RecordCount() As Long

    RecordCount = pRecordCount

End Property

Public Property Get AffectedRows() As Long

    AffectedRows = pAffectedRows

End Property

Public Function SetConnection(ByVal ConnectionString As String) As Boolean

    On Error GoTo Catch

    Set pConnection = VBA.Interaction.CreateObject("ADODB.Connection")

    pConnection.Open ConnectionString

    pClosable = True
    SetConnection = True

    GoTo Finally

Catch:
    Handle VBA.Information.Err.Number, VBA.Information.Err.Description, "", _
        "Function SetConnection", pModuleName

Finally:

End Function

Public Function Execute() As Boolean

    On Error GoTo Catch

    If Not VBA.Conversion.CBool(VBA.Strings.Len(pQuery)) Then _
        VBA.Information.Err.Raise -2147220989, _
            Description:="Query is empty"

    Dim Command As Object, Parameter As Object, ParameterName As Variant, _
        Result As Object

    Set Command = VBA.Interaction.CreateObject("ADODB.Command")
    Set Result = VBA.Interaction.CreateObject("Scripting.Dictionary")

    With Command
        .ActiveConnection = pConnection
        .ActiveConnection.CursorLocation = 3
        .CommandType = 1
        .CommandText = pQuery

        If VBA.Conversion.CBool(pParameters.Count) Then

            For Each ParameterName In pParameters.Keys
                Set Parameter = pParameters(ParameterName)
                .Parameters.Append Parameter

                VBA.Interaction.DoEvents
            Next ParameterName

        End If

        Set pRecords = .Execute(pAffectedRows)

        If Not VBA.Information.IsObject(pRecords) Then _
            VBA.Information.Err.Raise -2147220988, _
                Description:="Recordset is empty"

        If VBA.Conversion.CBool(pRecords.State) Then _
            pRecordCount = pRecords.RecordCount

        Execute = True

    End With

    GoTo Finally

Catch:
    Handle VBA.Information.Err.Number, VBA.Information.Err.Description, "", _
        "Function Execute", pModuleName

Finally:
    If VBA.Conversion.CBool(pParameters.Count) Then pParameters.RemoveAll
    Set Result = Nothing
    Set Command = Nothing
    Set Parameter = Nothing

End Function

Public Sub BeginTransaction()

    pConnection.BeginTrans
    pTransactionStarted = True

End Sub

Public Sub CommitTransaction()

    If pTransactionStarted Then pConnection.CommitTrans

End Sub

Public Sub RollbackTransaction()

    If pTransactionStarted Then pConnection.RollbackTrans

End Sub

Public Sub Bind(ByVal ParameterName As String, ByVal ParameterValue As Variant)

    On Error GoTo Catch

    If pParameters.Exists(ParameterName) Then _
        VBA.Information.Err.Raise -2147220991, _
            Description:="Parameter [" & ParameterName & "] exists"

    Dim Parameter As Object

    Set Parameter = VBA.Interaction.CreateObject("ADODB.Parameter")

    With Parameter
        .Name = ParameterName

        Select Case VBA.Information.VarType(ParameterValue)

            Case 8
                .Type = 200
                .Value = VBA.Conversion.CStr(ParameterValue)
                .Size = VBA.Conversion.CLng(VBA.Strings.Len(.Value))

            Case 2, 3
                .Type = 3
                .Value = VBA.Conversion.CLng(ParameterValue)

            Case 5
                .Type = 5
                .Value = VBA.Conversion.CDbl(ParameterValue)

            Case 7
                .Type = 7
                .Value = VBA.Conversion.CDate(ParameterValue)

            Case 11
                .Type = 11
                .Value = VBA.Conversion.CBool(ParameterValue)

            Case Else

        End Select

    End With

    pParameters.Add ParameterName, Parameter

    GoTo Finally

Catch:
    Handle VBA.Information.Err.Number, VBA.Information.Err.Description, "", _
        "Sub Bind", pModuleName

Finally:
    Set Parameter = Nothing

End Sub

Public Function ResultSet() As Object

    On Error GoTo Catch

    If Not VBA.Conversion.CBool(Execute) Then _
        VBA.Information.Err.Raise -2147220990, Description:="Does not executed"

    If (VBA.Conversion.CBool(pAffectedRows) Or _
        Not VBA.Conversion.CBool(pRecordCount)) Then GoTo Finally

    Dim Row As Long, Rows As Variant, RowsCount As Long, _
        FieldCounter As Long, Field As Object, RecordRow As Object, _
        FieldsCount As Long, Results As Object

    Set Result = VBA.Interaction.CreateObject("Scripting.Dictionary")

    FieldsCount = pRecords.Fields.Count
    Rows = pRecords.GetRows(pRecordCount)
    RowsCount = UBound(Rows, 2)

    For Row = 0 To RowsCount

        Set RecordRow = VBA.Interaction.CreateObject("Scripting.Dictionary")

        For FieldCounter = 0 To (FieldsCount - 1)
            Set Field = pRecords.Fields(FieldCounter)
            RecordRow.Add Field.Name, Rows(FieldCounter, Row)

            VBA.Interaction.DoEvents
        Next FieldCounter

        Results.Add Results.Count, RecordRow

        VBA.Interaction.DoEvents
    Next Row

    Set ResultSet = IIf((1 = pRecordCount), Results(0), Results)

    Erase Rows

    GoTo Finally

Catch:
    Handle VBA.Information.Err.Number, VBA.Information.Err.Description, "", _
        "Function ResultSet", pModuleName

Finally:
    Set Field = Nothing
    Set Results = Nothing
    Set RecordRow = Nothing

End Function