Advertisement
nandordudas

Private Data Object

Jun 2nd, 2016
124
0
Never
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
  1. Option Compare Binary
  2. Option Explicit
  3.  
  4. '   Dim PDO As DataObject, PDO2 As Object, PDO3 As Object, Results As Object, _
  5. '       Item As Variant
  6. '
  7. '   Set PDO = New DataObject
  8. '
  9. '   With PDO
  10. '       .Query = "SELECT n.* FROM tblName n WHERE n.FieldName = :ParameterName, "
  11. '       .Bind ":ParameterName", "ParameterValue"
  12. '       .Bind ":ParameterName", "ParameterValue"
  13. '
  14. '        If .Execute Then Debug.Print .RecordCount
  15. '   End With
  16. '
  17. '   Set PDO2 = New DataObject
  18. '
  19. '   With PDO2
  20. '
  21. '        .SetConnection "Provider=Microsoft.ACE.OLEDB.12.0;" _
  22. '            & "Data Source=*;" _
  23. '            & "Persist Security Info=False;"
  24. '
  25. '        .Query = "INSERT INTO tblName (FieldName, ) VALUES (:FieldValue, )"
  26. '        .Query = "UPDATE tblName n SET n.FieldName = :FieldValue,  WHERE n."
  27. '        .Bind ":FieldValue", "FieldValue"
  28. '        .Bind ":FieldValue", "FieldValue"
  29. '
  30. '        .BeginTransaction
  31. '
  32. '        If Not .Execute Then
  33. '            .RollbackTransaction
  34. '        Else
  35. '            .CommitTransaction
  36. '
  37. '            If VBA.Conversion.CBool(.AffectedRows) Then _
  38.                 Debug.Print "Inserted or updated"
  39. '        End If
  40. '   End With
  41. '
  42. '   Set PDO3 = New DataObject
  43. '
  44. '   With PDO3
  45. '        Access>File>Options>Client Settings>Advanced>Use Legacy Encryption
  46. '        .SetConnection "Provider=Microsoft.ACE.OLEDB.12.0;" _
  47. '            & "Data Source=*;" _
  48. '            & "Jet OLEDB:Database Password=*;"
  49. '
  50. '        .Query = "SELECT n.* FROM tblName n WHERE n.FieldName = :ParameterName"
  51. '        .Bind ":ParameterName", "ParameterValue"
  52. '        .Bind ":ParameterName", "ParameterValue"
  53. '
  54. '        Set Results = .ResultSet
  55. '
  56. '        If (1 = Results.Count) Then
  57. '            Debug.Print Results("SomeFieldName")
  58. '        Else
  59. '            For Each Item In Results
  60. '               Debug.Print Results(Item)("SomeFieldName")
  61. '            Next Item
  62. '        End If
  63. '    End With
  64. '
  65. '    Set Results = Nothing
  66. '    Set PDO = Nothing
  67. '    Set PDO2 = Nothing
  68. '    Set PDO3 = Nothing
  69.  
  70. Private pModuleName As String, pConnection As Object, pQuery As String, _
  71.     pParameters As Object, pRecords As Object, pAffectedRows As Long, _
  72.     pRecordCount As Long, pTransactionStarted As Boolean, pClosable As Boolean
  73.  
  74. Private Sub Class_Initialize()
  75.  
  76.     pModuleName = Application.VBE.ActiveCodePane.CodeModule.Name
  77.  
  78.     If ("Microsoft Access" = Application.Name) Then _
  79.         Set pConnection = Application.CurrentProject.Connection
  80. '        SetConnection ""
  81.    Else
  82. '        SetConnection ""
  83.    End If
  84.  
  85.     Set pParameters = VBA.Interaction.CreateObject("Scripting.Dictionary")
  86.  
  87. End Sub
  88.  
  89. Private Sub Class_Terminate()
  90.  
  91.     If pClosable Then pConnection.Close
  92.     Set pRecords = Nothing
  93.     Set pConnection = Nothing
  94.     Set pParameters = Nothing
  95.  
  96. End Sub
  97.  
  98. Public Property Get Query() As String
  99.  
  100.     Query = pQuery
  101.  
  102. End Property
  103.  
  104. Public Property Let Query(ByVal NewValue As String)
  105.  
  106.     pQuery = NewValue
  107.  
  108. End Property
  109.  
  110. Public Property Get RecordCount() As Long
  111.  
  112.     RecordCount = pRecordCount
  113.  
  114. End Property
  115.  
  116. Public Property Get AffectedRows() As Long
  117.  
  118.     AffectedRows = pAffectedRows
  119.  
  120. End Property
  121.  
  122. Public Function SetConnection(ByVal ConnectionString As String) As Boolean
  123.  
  124.     On Error GoTo Catch
  125.  
  126.     Set pConnection = VBA.Interaction.CreateObject("ADODB.Connection")
  127.  
  128.     pConnection.Open ConnectionString
  129.  
  130.     pClosable = True
  131.     SetConnection = True
  132.  
  133.     GoTo Finally
  134.  
  135. Catch:
  136.     Handle VBA.Information.Err.Number, VBA.Information.Err.Description, "", _
  137.         "Function SetConnection", pModuleName
  138.  
  139. Finally:
  140.  
  141. End Function
  142.  
  143. Public Function Execute() As Boolean
  144.  
  145.     On Error GoTo Catch
  146.  
  147.     If Not VBA.Conversion.CBool(VBA.Strings.Len(pQuery)) Then _
  148.         VBA.Information.Err.Raise -2147220989, _
  149.             Description:="Query is empty"
  150.  
  151.     Dim Command As Object, Parameter As Object, ParameterName As Variant, _
  152.         Result As Object
  153.  
  154.     Set Command = VBA.Interaction.CreateObject("ADODB.Command")
  155.     Set Result = VBA.Interaction.CreateObject("Scripting.Dictionary")
  156.  
  157.     With Command
  158.         .ActiveConnection = pConnection
  159.         .ActiveConnection.CursorLocation = 3
  160.         .CommandType = 1
  161.         .CommandText = pQuery
  162.  
  163.         If VBA.Conversion.CBool(pParameters.Count) Then
  164.  
  165.             For Each ParameterName In pParameters.Keys
  166.                 Set Parameter = pParameters(ParameterName)
  167.                 .Parameters.Append Parameter
  168.  
  169.                 VBA.Interaction.DoEvents
  170.             Next ParameterName
  171.  
  172.         End If
  173.  
  174.         Set pRecords = .Execute(pAffectedRows)
  175.  
  176.         If Not VBA.Information.IsObject(pRecords) Then _
  177.             VBA.Information.Err.Raise -2147220988, _
  178.                 Description:="Recordset is empty"
  179.  
  180.         If VBA.Conversion.CBool(pRecords.State) Then _
  181.             pRecordCount = pRecords.RecordCount
  182.  
  183.         Execute = True
  184.  
  185.     End With
  186.  
  187.     GoTo Finally
  188.  
  189. Catch:
  190.     Handle VBA.Information.Err.Number, VBA.Information.Err.Description, "", _
  191.         "Function Execute", pModuleName
  192.  
  193. Finally:
  194.     If VBA.Conversion.CBool(pParameters.Count) Then pParameters.RemoveAll
  195.     Set Result = Nothing
  196.     Set Command = Nothing
  197.     Set Parameter = Nothing
  198.  
  199. End Function
  200.  
  201. Public Sub BeginTransaction()
  202.  
  203.     pConnection.BeginTrans
  204.     pTransactionStarted = True
  205.  
  206. End Sub
  207.  
  208. Public Sub CommitTransaction()
  209.  
  210.     If pTransactionStarted Then pConnection.CommitTrans
  211.  
  212. End Sub
  213.  
  214. Public Sub RollbackTransaction()
  215.  
  216.     If pTransactionStarted Then pConnection.RollbackTrans
  217.  
  218. End Sub
  219.  
  220. Public Sub Bind(ByVal ParameterName As String, ByVal ParameterValue As Variant)
  221.  
  222.     On Error GoTo Catch
  223.  
  224.     If pParameters.Exists(ParameterName) Then _
  225.         VBA.Information.Err.Raise -2147220991, _
  226.             Description:="Parameter [" & ParameterName & "] exists"
  227.  
  228.     Dim Parameter As Object
  229.  
  230.     Set Parameter = VBA.Interaction.CreateObject("ADODB.Parameter")
  231.  
  232.     With Parameter
  233.         .Name = ParameterName
  234.  
  235.         Select Case VBA.Information.VarType(ParameterValue)
  236.  
  237.             Case 8
  238.                 .Type = 200
  239.                 .Value = VBA.Conversion.CStr(ParameterValue)
  240.                 .Size = VBA.Conversion.CLng(VBA.Strings.Len(.Value))
  241.  
  242.             Case 2, 3
  243.                 .Type = 3
  244.                 .Value = VBA.Conversion.CLng(ParameterValue)
  245.  
  246.             Case 5
  247.                 .Type = 5
  248.                 .Value = VBA.Conversion.CDbl(ParameterValue)
  249.  
  250.             Case 7
  251.                 .Type = 7
  252.                 .Value = VBA.Conversion.CDate(ParameterValue)
  253.  
  254.             Case 11
  255.                 .Type = 11
  256.                 .Value = VBA.Conversion.CBool(ParameterValue)
  257.  
  258.             Case Else
  259.  
  260.         End Select
  261.  
  262.     End With
  263.  
  264.     pParameters.Add ParameterName, Parameter
  265.  
  266.     GoTo Finally
  267.  
  268. Catch:
  269.     Handle VBA.Information.Err.Number, VBA.Information.Err.Description, "", _
  270.         "Sub Bind", pModuleName
  271.  
  272. Finally:
  273.     Set Parameter = Nothing
  274.  
  275. End Sub
  276.  
  277. Public Function ResultSet() As Object
  278.  
  279.     On Error GoTo Catch
  280.  
  281.     If Not VBA.Conversion.CBool(Execute) Then _
  282.         VBA.Information.Err.Raise -2147220990, Description:="Does not executed"
  283.  
  284.     If (VBA.Conversion.CBool(pAffectedRows) Or _
  285.         Not VBA.Conversion.CBool(pRecordCount)) Then GoTo Finally
  286.  
  287.     Dim Row As Long, Rows As Variant, RowsCount As Long, _
  288.         FieldCounter As Long, Field As Object, RecordRow As Object, _
  289.         FieldsCount As Long, Results As Object
  290.  
  291.     Set Result = VBA.Interaction.CreateObject("Scripting.Dictionary")
  292.  
  293.     FieldsCount = pRecords.Fields.Count
  294.     Rows = pRecords.GetRows(pRecordCount)
  295.     RowsCount = UBound(Rows, 2)
  296.  
  297.     For Row = 0 To RowsCount
  298.  
  299.         Set RecordRow = VBA.Interaction.CreateObject("Scripting.Dictionary")
  300.  
  301.         For FieldCounter = 0 To (FieldsCount - 1)
  302.             Set Field = pRecords.Fields(FieldCounter)
  303.             RecordRow.Add Field.Name, Rows(FieldCounter, Row)
  304.  
  305.             VBA.Interaction.DoEvents
  306.         Next FieldCounter
  307.  
  308.         Results.Add Results.Count, RecordRow
  309.  
  310.         VBA.Interaction.DoEvents
  311.     Next Row
  312.  
  313.     Set ResultSet = IIf((1 = pRecordCount), Results(0), Results)
  314.  
  315.     Erase Rows
  316.  
  317.     GoTo Finally
  318.  
  319. Catch:
  320.     Handle VBA.Information.Err.Number, VBA.Information.Err.Description, "", _
  321.         "Function ResultSet", pModuleName
  322.  
  323. Finally:
  324.     Set Field = Nothing
  325.     Set Results = Nothing
  326.     Set RecordRow = Nothing
  327.  
  328. End Function
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement