Database

Option Compare Database
Option Explicit

' 514: Doesn't executed
' 515: Query is empty
' 516: Recordset is closed
' 517: Recordset is empty

#If Debugging Then
Private pLogMessage As String
#End If

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()

    Set pConnection = CurrentProject.Connection
    Set pParameters = CreateObject("Scripting.Dictionary")

End Sub

Private Sub Class_Terminate()

    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

#If Debugging Then
    pLogMessage = pLogMessage & "Query: " & vbCrLf & vbTab & pQuery & _
        vbCrLf & pLogMessage & "Parameters: " & vbCrLf
#End If

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, , "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 Not pRecords Is Nothing Then _
            If CBool(pRecords.State) Then pRecordCount = pRecords.RecordCount

        Executed = True

    End With

    GoTo Finally

Catch:
    RollbackTransaction

    Handle Err.Number, Err.Description, "", "Function Execute", _
        VBE.ActiveCodePane.CodeModule.Name

Finally:
    Execute = Executed

#If Debugging Then
    pLogMessage = pLogMessage & "Executed: " & Executed & vbCrLf
    pLogMessage = pLogMessage & "RecordCount: " & pRecordCount & vbCrLf
    pLogMessage = pLogMessage & "AffectedRows: " & pAffectedRows & vbCrLf
#End If

    pParameters.RemoveAll
    Set Parameter = Nothing
    Set Result = Nothing
    Set Command = Nothing

End Function

Public Sub BeginTransaction()

    pConnection.BeginTrans

#If Debugging Then
    pLogMessage = pLogMessage & "Transaction initiated" & vbCrLf
#End If

End Sub

Public Sub CommitTransaction()

    pConnection.CommitTrans

#If Debugging Then
    pLogMessage = pLogMessage & "Transaction committed" & vbCrLf
#End If

End Sub

Public Sub RollbackTransaction()

    pConnection.RollbackTrans

#If Debugging Then
    pLogMessage = pLogMessage & "Transaction rolled back" & vbCrLf
#End If

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, , "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

#If Debugging Then
    pLogMessage = pLogMessage & vbTab & .Name & " = " & .Value & vbCrLf
#End If

    End With

    pParameters.Add ParameterName, Parameter

    GoTo Finally

Catch:
    Handle Err.Number, Err.Description, "", "Sub Bind", _
        VBE.ActiveCodePane.CodeModule.Name

Finally:
    Set Parameter = Nothing

End Sub

Public Function ResultSet() As Object

    On Error GoTo Catch

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

    BeginTransaction

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

    CommitTransaction

    Set Result = CreateObject("Scripting.Dictionary")

    If CBool(AffectedRows) Then GoTo Finally

    If pRecords Is Nothing Then _
        Err.Raise vbObjectError + 517, , "Recordset is empty"
'   BOF vagy EOF vizsgalata esetleg RecordCount?
    If Not CBool(pRecords.State) Then _
        Err.Raise vbObjectError + 516, , "Recordset is closed"

    FieldsCount = pRecords.Fields.Count

    Rows = pRecords.GetRows(pRecordCount)

    For Row = 0 To UBound(Rows, 2)

        Set RecordRow = CreateObject("Scripting.Dictionary")

        For FieldCounter = 0 To (FieldsCount - 1)

            RecordRow.Add pRecords.Fields(FieldCounter).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", _
        VBE.ActiveCodePane.CodeModule.Name

Finally:

#If Debugging Then
    Debug.Print pLogMessage
    pLogMessage = ""
#End If

    Set RecordRow = Nothing
    Set Result = Nothing

End Function