Link to home
Start Free TrialLog in
Avatar of Hankwembo Christopher,FCCA,FZICA,CIA,MAAT,B.A.Sc
Hankwembo Christopher,FCCA,FZICA,CIA,MAAT,B.A.ScFlag for Zambia

asked on

How to add data to a new dictionary in Ms Access using VBA

I'm trying to add data to the dictionary in ms access 2016 but the data collected via a SELECT query is not being added , kindly help me to spot the mistake on the code below. To be sure I want to print the data using a message, only then can I take the data to its final destination:

Private Sub CmdSales_Click()
    Dim jsonitems As New Collection
    Dim jsonDictionery As New Dictionary
    Dim i As Long
    Dim db As DAO.Database
    Dim rs As DAO.Recordset
    Dim item As Variant
    Set db = CurrentDb
    Set rs = db.OpenRecordset("Qry1")
    i = 2
    For Each item In jsonitems
        
        With rs
            
            ![INV] = item("INV")
            ![Customer] = item("Customer")
            ![TaxId] = item("TaxId")
            ![Address] = item("Address")
            ![InvoiceDate] = item("InvoiceDate")
            ![Product] = item("Product")
            ![Qty] = item("Qty")
            ![Price] = item("Price")
            ![VAT] = item("VAT")
            ![TotalPrice] = item("TotalPrice")
            End With
            jsonitems.Add jsonDictionery
            Set jsonDictionery = Nothing
            i = i + 1
    Next
    rs.Close
    Set rs = Nothing
    Set jsonitems = Nothing
    MsgBox JsonConverter.ConvertToJson(jsonitems, Whitespace:=3)
End Sub

Open in new window

Avatar of John Tsioumpris
John Tsioumpris
Flag of Greece image

Based on your code
jsonDictionery.Add "INV", item("INV")
jsonDictionery.Add "Customer", item("Customer")
...... Fill the rest

Open in new window

Avatar of Hankwembo Christopher,FCCA,FZICA,CIA,MAAT,B.A.Sc

ASKER

Sorry sir it is still showing nothing or empty message box

But the excel format works see the same code

Sub ConvertJson()
Dim excelRange As Range
Dim jsonItems As New Collection
Dim jsonDictionary As New Dictionary
Dim i As Long
Dim cell As Variant
Set excelRange = Cells(1, 1).CurrentRegion

For i = 2 To excelRange.Rows.Count
    jsonDictionary("id") = Cells(i, 1)
    jsonDictionary("name") = Cells(i, 2)
    jsonDictionary("username") = Cells(i, 3)
    jsonDictionary("email") = Cells(i, 4)
    jsonDictionary("street") = Cells(i, 5)
    jsonDictionary("suite") = Cells(i, 6)
    jsonDictionary("city") = Cells(i, 7)
    jsonDictionary("zipcode") = Cells(i, 8)
    jsonDictionary("phone") = Cells(i, 9)
    jsonDictionary("website") = Cells(i, 10)
    jsonDictionary("company") = Cells(i, 11)

    jsonItems.Add jsonDictionary
    Set jsonDictionary = Nothing
Next i

MsgBox ConvertToJson(jsonItems, Whitespace:=2)

End Sub

Open in new window



User generated image
Correct. Cause in Excel you're writing into your dictionary, but in Access you're writing into your record set.

Thus the question: What is your data source in Access?
ASKER CERTIFIED SOLUTION
Avatar of ste5an
ste5an
Flag of Germany image

Link to home
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
Start Free Trial
Dear ste5an

Thank you so much for sporting the errors, however, I still have user defined not defined on

coll as scripting .collection

User generated image
comment this line
Set jsonDictionary = Nothing

Open in new window

If you have Scripting Runtime in the References check you will be OK
User generated imageUser generated image
Dear ste5an;

Thank you so much for guiding to right direction, without your help I do not think that this issue will have been sorted out. But I have made a few change to code and has work very well:

Private Sub CmdSales_Click()
Const SQL_SELECT As String = "SELECT INV, Customer, TaxId, Address, InvoiceDate, Product, Qty, Price, VAT, TotalPrice FROM Qry1;"

  Dim coll As New Collection
  Dim dict As Scripting.Dictionary
  Dim db As DAO.Database
  Dim rs As DAO.Recordset
  Dim fld As DAO.Field

  Set coll = New Collection
  Set db = CurrentDb
  Set rs = db.OpenRecordset(SQL_SELECT, dbOpenSnapshot)
  If Not rs.BOF And Not rs.EOF Then
    Do While Not rs.EOF
      Set dict = New Scripting.Dictionary
      For Each fld In rs.Fields
        dict.Add fld.Name, rs.Fields(fld.Name)
      Next fld

      coll.Add dict
      rs.MoveNext
    Loop
  End If

  rs.Close
  Set fld = Nothing
  Set rs = Nothing
  Set db = Nothing
  Set dict = Nothing
  MsgBox JsonConverter.ConvertToJson(coll, Whitespace:=3)
  Set coll = Nothing
End Sub
Always specify the library where a class is defined:

Dim coll As VBA.Collection

Set coll = New VBA.Collection

Open in new window

When you want the default collection. Never let the compiler decide this. Cause in complex scenarios the order of resolution may change, thus your code can break. Happened in the past with Recordset (ADO vs DAO).
It would be better for you to clear the dictionary than to create a new one.

Use the RemoveAll method.
https://docs.microsoft.com/en-us/office/vba/language/reference/user-interface-help/dictionary-object#methods
@Aikimark: Nope., not in this case. Collection.Add dict adds a reference not a value-copy.

 User generated image
Option Explicit

Public Sub Test1()

  Dim coll As VBA.Collection
  Dim dict As Scripting.Dictionary

  Set coll = New VBA.Collection

  Set dict = New Scripting.Dictionary
  dict.Add "1", 1
  dict.Add "2", 2
  coll.Add dict
  Set dict = Nothing

  Set dict = New Scripting.Dictionary
  dict.Add "3", 3
  dict.Add "4", 4
  coll.Add dict
  Set dict = Nothing

  Set coll = Nothing

End Sub

Public Sub Test2()

  Dim coll As VBA.Collection
  Dim dict As Scripting.Dictionary

  Set coll = New VBA.Collection

  Set dict = New Scripting.Dictionary
  dict.Add "1", 1
  dict.Add "2", 2
  coll.Add dict

  dict.RemoveAll

  dict.Add "3", 3
  dict.Add "4", 4
  coll.Add dict
  Set dict = Nothing

  Set coll = Nothing

End Sub

Open in new window

Still I cannot get to work,

I have now run out of ideas.
Still I cannot get to work,
This does not tell us what your problem is. Especially as you wrote earlier:

But I have made a few change to code and has work very well: