DataObject

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "DataObject"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Compare Database
Option Explicit

Private pModuleName As String
Private pConnection As Object
Private pQuery As String
Private pParameters As Object
Private pRecords As Object
Private pAffectedRows As Long
Private pRecordCount As Long

Private Sub Class_Initialize()

    pModuleName = VBE.ActiveCodePane.CodeModule.Name
    Set pConnection = CurrentProject.Connection
    Set pParameters = CreateObject("Scripting.Dictionary")

End Sub

Private Sub Class_Terminate()

    pModuleName = ""
    Set pConnection = Nothing
    Set pParameters = Nothing
    Set pRecords = 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 Execute() As Boolean

    On Error GoTo Catch

    If Not CBool(Len(pQuery)) Then _
        Err.Raise vbObjectError + 515, Description:="Query is empty"

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

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

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

        For Each ParameterName In pParameters.Keys

            Set Parameter = pParameters(ParameterName)

            .Parameters.Append Parameter

            DoEvents
        Next ParameterName

        Set pRecords = .Execute(pAffectedRows)

        If pRecords Is Nothing Then
            Err.Raise vbObjectError + 516, Description:="Recordset is empty"
        Else
            If CBool(pRecords.State) Then pRecordCount = pRecords.RecordCount
        End If

        Executed = True

    End With

    GoTo Finally

Catch:
    RollbackTransaction

    Handle Err.Number, Err.Description, "", "Function Execute", pModuleName

Finally:
    Execute = Executed
    pParameters.RemoveAll
    Set Parameter = Nothing
    Set Result = Nothing
    Set Command = Nothing

End Function

Public Sub BeginTransaction()

    pConnection.BeginTrans

End Sub

Public Sub CommitTransaction()

    pConnection.CommitTrans

End Sub

Public Sub RollbackTransaction()

    pConnection.RollbackTrans

End Sub

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

    On Error GoTo Catch

    If pParameters.Exists(ParameterName) Then _
        Err.Raise vbObjectError + 513, _
            Description:="Parameter exists [" & ParameterName & "]"

    Dim Parameter As Object

    Set Parameter = CreateObject("ADODB.Parameter")

    With Parameter
        .Name = ParameterName

        Select Case VarType(ParameterValue)

            Case vbString
                .Type = 200
                .Value = CStr(ParameterValue)
                .Size = Len(.Value)

            Case vbInteger, vbLong
                .Type = vbLong
                .Value = CLng(ParameterValue)

            Case vbDouble
                .Type = vbDouble
                .Value = CDbl(ParameterValue)

            Case vbDate
                .Type = vbDate
                .Value = CDate(ParameterValue)

            Case vbBoolean
                .Type = vbBoolean
                .Value = CBool(ParameterValue)

            Case Else

        End Select

    End With

    pParameters.Add ParameterName, Parameter

    GoTo Finally

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

Finally:
    Set Parameter = Nothing

End Sub

Public Function ResultSet() As Object

    On Error GoTo Catch

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

    BeginTransaction

    If Not CBool(Execute) Then _
        Err.Raise vbObjectError + 514, Description:="Doesn't executed"

    CommitTransaction

    Set Result = CreateObject("Scripting.Dictionary")

    If (CBool(AffectedRows) Or Not CBool(pRecordCount)) Then GoTo Finally

    FieldsCount = pRecords.Fields.Count

    Rows = pRecords.GetRows(pRecordCount)

    RowsCount = UBound(Rows, 2)

    For Row = 0 To RowsCount

        Set RecordRow = CreateObject("Scripting.Dictionary")

        For FieldCounter = 0 To (FieldsCount - 1)

            Set Field = pRecords.Fields(FieldCounter)

            RecordRow.Add Field.Name, Rows(FieldCounter, Row)
        Next FieldCounter

        Result.Add Result.Count, RecordRow
    Next Row

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

    Erase Rows

    GoTo Finally

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

Finally:
    Set Field = Nothing
    Set RecordRow = Nothing
    Set Result = Nothing

End Function