Parse JSON, MS Access VBA (nested loops) - json

good people of StackOverflow!
I am trying to figure out how to connect to Airtable API, get JSON from there and populate Access table with the results.
So far, at least I managed to restrict the request to give me only a few fields I need.The result looks like this:
{
"records": [{
"id": "rec008lgyvVmwk1F4",
"fields": {
"Date": "2018-02-28"
},
"createdTime": "2018-01-26T15:36:23.000Z"
}, {
"id": "rec02WozJeaGvfBfj",
"fields": {
"Hours": 1.5,
"Date": "2018-02-09",
"Project": ["Nonbillable"]
},
"createdTime": "2018-02-12T17:03:18.000Z"
}, {
"id": "rec05VxP0CYTsDYOA",
"fields": {
"Date": "2018-02-08"
},
"createdTime": "2018-02-01T10:29:52.000Z"
}, {
"id": "rec05xoQEm5iWIYmz",
"fields": {
"Hours": 0.75,
"Date": "2018-02-16",
"Project": ["2018 - Japan DLAs"]
},
"createdTime": "2018-02-19T09:29:18.000Z"
}]
}
From that point on I have read as many examples as I could find how to use VBA-JSON by Tim Hall (thank you Tim, for creating it :)
As far as I understand, in my case the ParseJson function returns a dictionary. Inside that is a collection named 'results' and inside that collection is another dictionary named 'fields'.
What I need are values for keys 'Hours', 'Date' and 'Project' from that dictionary.
I have tried to do those three loops (loop through dictionary inside collection inside dictionary) and was failing miserably many times with a variety of errors. Finally, I have come to the point where I see no more errors, the sub happily gives me "Import done!" message. Alas, my table is empty!
What, what am I doing wrong?
I hope I gave you enough information and thank you very much in advance for your help!
(If it matters, I'm working with 32-bit Access 2016 on 64-bit Windows)
Public Sub ImportJSON()
Dim reader As New XMLHTTP60
Dim JsonRetrieved As String
Dim Parsed As Scripting.Dictionary
Dim records As New Collection
Dim fields As Scripting.Dictionary
Dim item As Variant
Dim rs As New ADODB.Recordset
reader.Open "GET", "https://api.airtable.com/v0/apppLTTgKBsw5QmUX/myTable?fields[]=Project&fields[]=Hours&NOT({Hours} = '')&fields[]=Date&NOT({Date} = '')&maxRecords=4&api_key=mykey", False
reader.setRequestHeader "Accept", "application/json"
reader.Send
Do Until reader.ReadyState = 4
DoEvents
Loop
If reader.Status = 200 Then
rs.Open "tblAirtableImport", CurrentProject.Connection, _
adOpenKeyset, adLockOptimistic
JsonRetrieved = reader.responseText
'Debug.Print JsonRetrieved
Set Parsed = JsonConverter.ParseJson(JsonRetrieved)
'loop through dictionary 'Parsed'
Dim i As Long
For i = 0 To Parsed.Count - 1
'loop through collection 'records'. If we have hours logged into Airtable add new record (Hours, Date, Project) to Access table
For Each fields In records
'loop through dictionary 'fields'
Dim j As Long
For j = 0 To fields.Count - 1
If fields.Exists("Hours") Then
'MsgBox "We have hours in this row"
rs.AddNew
rs!AirtableHours = fields.item("Hours")
rs!AirtableDate = fields.item("Date")
rs!AirtableProject = fields.item("Project")
rs.Update
Else
MsgBox "No logged time."
End If
Next j
Next
Next i
MsgBox "Import done!"
Set Parsed = Nothing
Else
MsgBox "Ups, unable to import data. Reader status is: " & reader.Status
End If
End Sub

The entry Project holds an Array so take the first Item:
Set Parsed = JsonConverter.ParseJson(JsonRetrieved)
For Each record In Parsed("records")
Set fields = record("fields")
If fields.Exists("Hours") Then
rs.AddNew
rs!AirtableHours = fields("Hours")
rs!AirtableDate = fields("Date")
rs!AirtableProject = fields("Project")(1)
rs.Update
End If
Next

Related

Nested JSON for Cardano Blockchain

Hello after i successfully parsed my metadata into an excel im now at the challenge to parse it back to an Cardano Blockchain compatible Metadata.JSON
but unfortunatly im not able to fit the right metadata structur
Thats what it should be:
{
"721": {
"policy": {
"tokenname": {
"country": "1",
"test": "123"
},
"tokenname": {
"country": "1",
"test": "123"
}
}
}
}
thats my current status:
my code and result
Sub live_json()
Dim rng As Range, items As New Collection, myitem As New Dictionary, subitem As New Dictionary, i As Integer, cell As Variant
'Set rng = Range("A2:A3")
'Set rng = Range(Sheets(2).Range("A2"), Sheets(2).Range("A2").End(xlDown)) use this for dynamic range
Set abc = New Collection
abc.Add ("721")
For a = 0 To 2
subitem("country") = "123"
subitem("test") = "123"
myitem.Add "tokenname", subitem
items.Add myitem
Set myitem = Nothing
Set subitem = Nothing
Next
abc.Add items
MsgBox (ConvertToJson(abc, Whitespace:=2))
End Sub
I think im nearly there
This worked for me:
Sub live_json()
Dim root As Dictionary, k As Dictionary, a As Long
Set root = New Dictionary
Set k = New Dictionary
root.Add "721", k
k.Add "policy", New Dictionary
Set k = k("policy")
For a = 0 To 2
k.Add "tokenname" & a, New Dictionary
With k("tokenname" & a)
.Add "country", "1"
.Add "test", "123"
End With
Next
Debug.Print ConvertToJson(root, Whitespace:=2)
End Sub

VBA/JSON Parse Json data from arrays

Im trying to parse Data from a json object with several arrays.
This code as an Example:
{
"Version": "1.0",
"I.1": [
{
"MethodenID": "I.1.3",
"Ranking": "1",
"Punktzahl": "20"
},
{
"MethodenID": "I.1.1",
"Ranking": "3",
"Punktzahl": "68"
}
],
"I.2": [
{
"MethodenID": "I.2.2",
"Ranking": "1",
"Punktzahl": "87"
},
{
"MethodenID": "I.2.1",
"Ranking": "2",
"Punktzahl": "67"
}
]}
I want to get only the objects from the inner arrays.
I tried the power query tool excel has but ran into some problems having to access every inner list seperately.
After that i tried my luck with vba but had the same problem.
My Question now is: Is it possible at all to do this with vba?
If not is it somehow possible to convert the file into a more readable state?
I tried out the JsonConverter https://github.com/VBA-tools/VBA-JSON already.
Private Sub CommandButton1_Click()
Dim fd As Office.FileDialog
Dim ws As Worksheet
Set ws = Worksheets("Tabelle1")
Set fd = Application.FileDialog(msoFileDialogFilePicker)
With fd
.Title = "Select a json file"
.AllowMultiSelect = False
If .Show() Then
ws.Cells(1, 200) = "1"
Filename = (.SelectedItems(1))
Dim content As String
Dim iFile As Integer: iFile = FreeFile
Open Filename For Input As #iFile
content = Input(LOF(iFile), iFile)
'MsgBox (content)
'Parse JSON String
Dim products As Object
Set products = JsonConverter.ParseJson(content)
i = 1
For Each Product In products
ws.Cells(i, 1) = Product("MethodenID")
ws.Cells(i, 2) = Product("Ranking")
ws.Cells(i, 3) = Product("Punktzahl")
i = i + 1
Next
Close #iFile
End If
End With
End Sub
I came up with this from this tutorial: https://www.youtube.com/watch?v=fukOV0hG4eU&t=363s
Sadly i dont seem to be able to get to the values in the inner arrays.
Something like this:
Dim k, arr
Dim Json As Object
'reading json from a worksheet cell...
Set Json = JsonConverter.ParseJson(Range("C3").Value)
For Each k In Array("I.1", "I.2")
Set arr = Json(k) 'arr here is a VBA Collection object
For Each o In arr 'o here is a scripting dictionary
Debug.Print o("MethodenID"), o("Ranking"), o("Punktzahl")
Next o
Next k

Set value of apiDefaults to a variable

I have been trying to find a way to extract rows of data from an SQL database, format the returned rows into a JSON format and post/send that to a JSON web API. I am using an asp JSON serializer for VBScript (.Flush) to transform the SQL data into JSON. It works great, I have the structure i need and I also have the method to send the JSON formatted data. So what's the issue you might ask.....
The issue is I can't send apiDefaults.flush to the webserver, it does not work. If I send the same data as a hardcoded variable it works perfectly and the API takes the data.
Let me explain some more.
Here is the JSON output I see on screen using apiDefaults.flush This is perfectly formatted exactly what i need.
{"authentication": { "apiKey": "123456789101112131415" }, "createProperties": [ { "name": "Property 1", "propKey": "6sf3zqq151n2wkah" }, { "name": "Property 2", "propKey": "yuf38zc4cls9hz19" } ] }
However, I can't get this value stored into a variable. If I could simply do the following, my issue would be resolved but you can't bind a the .flush method to a variable?!?! I don't understand why as it is just a string of text in theory.
dim myJson = apiDefaults.flush
This bit of code here is where I set the values to send to the web server, my variable that holds the JSON string
'IF I USE THIS IT WORKS PERFECTLY, IT TAKES MY MANUALLY CREATED VARIABLE/STRING AND SENDS IT
oXMLHttp.send strmultiprop
'THIS IS WHAT I FIGURED I SHOULD BE ABLE TO USE BUT IT IS NOT TREATED LIKE A VARIABLE
oXMLHttp.send apiDefaults.flush
' I TRIED THIS AND THIS WON'T WORK EITHER
oXMLHttp.send myJson
Below is my actual scripts
<% #LANGUAGE="VBSCRIPT" CODEPAGE="65001" %>
<!--#include file="JSON_2.0.4.asp"-->
<%
Function QueryToJSON(dbcomm, params)
Dim rs, jsa, aaa, bbb
Set rs = dbcomm.Execute(,params,1)
Set jsa = jsArray()
Do While Not (rs.EOF Or rs.BOF)
Set jsa(Null) = jsObject()
For Each col In rs.Fields
jsa(Null)(col.Name) = col.Value
Next
rs.MoveNext
Loop
Set QueryToJSON = jsa
rs.Close
End Function
strConn = "PROVIDER=SQLOLEDB;DATA SOURCE=LOCALHOST;UID=sa;PWD=********;DATABASE=DB_Site"
Set conn = Server.CreateObject("ADODB.Connection")
conn.Open strConn
query = "SELECT wce_uid as name, uniqueid as propKey FROM wces_users WHERE Prop_Moved = ?"
CustomerID = "Y" 'Request.QueryString("CustomerID")
arParams = array(CustomerID)
Set cmd = Server.CreateObject("ADODB.Command")
cmd.CommandText = query
Set cmd.ActiveConnection = conn
' https://stackoverflow.com/questions/40781130/setting-up-rest-api-in-classic-asp
key = "1234567891011121314151678910"
url = "https://www.beds24.com/api/json/createProperties"
'1 PROPERTY WORKING
str1prop = "{""authentication"": { ""apiKey"": ""123456789101112131415"" }, ""createProperties"": [ { ""name"": ""New Test"", ""propKey"": ""NewTest1"" } ] }"
'2 PROPERTY WORKING
strmultiprop = "{""authentication"": { ""apiKey"": ""123456789101112131415"" }, ""createProperties"": [ { ""name"": ""3333"", ""propKey"": ""3333"" }, { ""name"": ""4444"", ""propKey"": ""4444"" } ] }"
set apiDefaults = QueryToJSON(cmd, arParams)
'3 THE FLUSH METHOD --- THIS DOES NOT SET THE VRIABLE TO THE OUTPUT I SEE ON SCREEN
dim myJson = apiDefaults.flush
apiDefaults.flush
conn.Close : Set Conn = Nothing
Dim oXMLHttp
Set oXMLHttp=Server.Createobject("MSXML2.ServerXMLHTTP.6.0")
oXMLHttp.open "POST", url,false
oXMLHttp.setRequestHeader "Content-Type", "application/json"
oXMLHttp.send apiDefaults.flush 'THIS IS THE ISSUE LINE USING THIS. if I CHANGE TO strmultiprop NO ISSUES AT ALL.
response.write oXMLHttp.responseText
Set oXMLHttp = Nothing
%>
Any advice on this would be great.
Thanks for looking.
My question was answered by #SearchAndResQ
"Try oXMLHttp.send apiDefaults.jsString, you need the value in that property"

Json parse not getting the value inside the 2nd curly braces

I am using ACCESS VBA to parse Json.
It is getting the value that are in the 1st curly braces.
But anything within the 2nd curly gives an error
Wrong number of arguments of invalid property assignment
JSON:
[
{
"Number": 1,
"Name": "John Doe",
"DateOfB": "2018-05-05",
"Place": {
"Pl": 4,
"Name": "England"
}
}
]
I am able to get the values for Number, Name and DateofB.
But I'm unable to get the value for Place for that I am getting the error.
I am using the widly available clsJsonParser module in my VBA application.
Following the sample in the clsJsonParser this is what works for you:
Public Sub TestJSON()
Dim JP As JSONParser
Set JP = New JSONParser
JP.Filename = "c:\myJson.txt"
Dim varData As Variant
Set varData = JP.Parse
Debug.Print varData(1)("Number")
Debug.Print varData(1)("Name")
Debug.Print varData(1)("DateOfB")
'You have to explicitely use a Dictionary type here to store the place.
Dim placeDictionary As Scripting.Dictionary
Set placeDictionary = varData(1)("Place")
'Output all keys and items of the place dictionary:
Dim index As Long
For index = 0 To placeDictionary.Count - 1
Debug.Print placeDictionary.Keys(index), placeDictionary.Items(index)
Next index
'Access place dictionary items by name:
Debug.Print placeDictionary("Pl")
Debug.Print placeDictionary("Name")
End Sub
You have to reference the Microsoft Scripting Runtime to introduce the type Scripting.Dictionary.
Code Below Worked:
For Each Appt In JSON
rs.AddNew
rs!Appt_ID = Appt("Number")
rs!ClientFullName = Appt("Name")
rs!Appt_Date = Appt("DateOfB")
rs!TC_Center = Appt("Place")("Pl")
rs.Update
Next

Loop JSON in array for same value in VBA

I am trying to get "image_id" from the below json in different columns of a row.
[
{
"spin": "HM4C6L",
"attributes": {
"product name": "Everest Kutilal Coarse Ground Red Chilli Powder ",
},
"bar_code": {
"valid": true,
"id": "89017817",
"type": "UPC"
},
"spin_state": "LIVE",
"meta": {
"updated-by": "undefined"
},
"version": null,
"images": [
{
"image_id": "dvuewrnauxdroqcapjiu",
"image_name": "masala and spice_HM4A7I2C6L_MN.JPG",
"shot_type": "MN"
},
{
"image_id": "tcku7lwarkv8ch0ao9cu",
"image_name": "masala and spice_HM4A7I2C6L_AL1.JPG",
"shot_type": "AL1"
},
{
"image_id": "b2znlmm59plprrkmkujs",
"image_name": "masala and spice_HM4A7I2C6L_AL2.jpg",
"shot_type": "AL2"
}
]
}
]
I tried Cannot iterate when parsing HTML table using JSON-VBA and Loop through the JSON object keys in excel vba.
Sub getimage()
Dim current As Workbook
Dim sht As Worksheet
Dim a, b, strUrl As String
Dim count As Variant
Set current = ActiveWorkbook
For Each sht In current.Worksheets
On Error Resume Next
'Application.ScreenUpdating = False
Set HTTPReq = CreateObject("WinHttp.WinHttpRequest.5.1")
count = Range("A1", Range("A1").End(xlDown)).Rows.count
For i = 2 To count
a = CStr(Range("A" & i).Value)
HTTPReq.Open "GET", "link" & a, False
HTTPReq.send
'Debug.Print HTTPReq.ResponseText
Dim Json, item As Object
Set Json = JsonConverter.ParseJson(HTTPReq.ResponseText)
For Each item In Json
Debug.Print item("images")
sht.Cells(i, B) = item("image_id")("1")
sht.Cells(i, B) = item("image_id")("2")
next Item
Next i
'Application.ScreenUpdating = True
End If
Next sht
End Sub
I need "dvuewrnauxdroqcapjiu" in cell B2, tcku7lwarkv8ch0ao9cu in cell C2, and "b2znlmm59plprrkmkujs" in cell C2, but my code is giving no output, no error.
A number of things.
Your json is malformed. There is an extra "," here:
"Everest Kutilal Coarse Ground Red Chilli Powder ",
which means jsonconverter will throw an error. The "," at the end would be to separate the current key-value pair from the next. There isn't a following pair so it should be removed.
Your path for accessing is wrong.
Here I am reading the corrected json from cell A1
Option Explicit
Public Sub test()
Dim json As Object, i As Long, item As Object, c As Long
i = 2: c = 2
Set json = JsonConverter.ParseJson([A1])(1)("images")
For Each item In json
ActiveSheet.Cells(i, c) = item("image_id")
c = c + 1
Next
End Sub
Cells(2,B) will expect B to be a variable as string literals are wrapped in "" i.e. "B". Also, you need a counter variable which is incremented or you will keep writing to the same cell.