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
ASKER
Sorry sir it is still showing nothing or empty message box
But the excel format works see the same code
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
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?
Thus the question: What is your data source in Access?
ASKER CERTIFIED SOLUTION
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
ASKER
comment this line
Set jsonDictionary = Nothing
ASKER
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_SELEC T, 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.ConvertToJso n(coll, Whitespace:=3)
Set coll = Nothing
End Sub
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_SELEC
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.ConvertToJso
Set coll = Nothing
End Sub
Always specify the library where a class is defined:
Dim coll As VBA.Collection
Set coll = New VBA.Collection
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
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.
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
ASKER
Still I cannot get to work,
I have now run out of ideas.
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:
Open in new window