VBA/JSON Parse Json data from arrays - json

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

Related

create JSON using JSONCOVERTER

I am wondering to create a json from VBA Outlook to export email as ticket on Osticket System
Everithing working well except when there's multiple attachments
I need to have this syntax
{
"alert": "true",
"autorespond": "true",
"source": "API",
"name": "Angy User",
"email": "Angry#somewhere.com",
"subject": "Help",
"topicId": "1",
"message": "data:text/html,</body></html>Please Help</body></html>",
"attachments": [
{ "MyFile.png": "data:image/png;base64,JVBERi0........." },
{ "MyFile.png": "data:image/png;base64,JVBERi0........." },
]
}
But using my code i get this
{
"alert": "true",
"autorespond": "true",
"source": "API",
"name": "Angy User",
"email": "Angry#somewhere.com",
"subject": "Help",
"topicId": "1",
"message": "data:text/html,</body></html>Please Help</body></html>",
"attachments": [
{ "MyFile.png": "data:image/png;base64,JVBERi0.........",
"MyFile.png": "data:image/png;base64,JVBERi0........." },
]
}
I use this to create the json
Dim Body As New Dictionary
Body.Add "alert", "true"
Body.Add "autorespond", "true"
Body.Add "source", "API"
Body.Add "name", myMsg.SenderName
Body.Add "email", FromAddress
Body.Add "subject", myMsg.Subject
Body.Add "topicId", CStr(rubriq)
Body.Add "message", "data:text/html," & strData 'myMsg.HTMLBody
Body.Add "attachments", Array(Attm1) 'attachments
Dim json As String
json = JsonConverter.ConvertToJson(Body, Whitespace:=" ")
Where the Attm1 is a dictionary filled in FOR loop
Attm1.Add oFile.FileName, "data:" & _
oFile.PropertyAccessor.GetProperty(PR_ATTACH_CONTENT_TYPE) & _
";" & "base64," & n.nodeTypedValue
I used this function
https://github.com/VBA-tools/VBA-JSON
The loop code
Dim attachments As New Collection
If myMsg.attachments.Count > 0 Then
Set fs = CreateObject("Scripting.FileSystemObject")
Set nAtt = xmlTicket.createElement("attachments")
nodeTicket.appendChild nAtt
For i = 1 To myMsg.attachments.Count
Set oFile = myMsg.attachments.Item(i)
'I only add attachments up to a limit in size
If oFile.Size <= MAX_ATTACHMENT Then
sTmpFile = fs.GetTempName
oFile.SaveAsFile sTmpFile
'Attachment data is always base64-coded
n.dataType = "bin.base64"
'The ADODB.Stream tweak allows to read binary files
Set data = CreateObject("ADODB.Stream")
data.Type = 1 'Binary
data.Open
data.LoadFromFile sTmpFile
'MSXML will base64-code it for us
n.nodeTypedValue = data.Read
'Using the bin.base64 structure means adding namespace'd attributes.
'For some reason, osTicket will complain for each extra attribute, so
'we get to clean up
n.Attributes.removeNamedItem "dt:dt"
'For some reason, getting the content-type is very unclear in Outlook
Set a = xmlTicket.createAttribute("type")
a.Value = oFile.PropertyAccessor.GetProperty(PR_ATTACH_CONTENT_TYPE)
n.Attributes.setNamedItem a
Dim Attm1 As New Dictionary
Attm1.Add oFile.FileName, "data:" & oFile.PropertyAccessor.GetProperty(PR_ATTACH_CONTENT_TYPE) & ";" & "base64," & n.nodeTypedValue
Kill sTmpFile
End If
Next
End If
Try something like this. It's easier to manage if you split out the various jobs into separate methods.
Const MAX_ATTACHMENT As Long = 500000 'or whatever
Sub MainSub()
Dim Body As Object, dict As Object, i As Long, json As String
Dim myMsg As Outlook.MailItem
'...
'...
Body.Add "attachments", New Collection
If myMsg.attachments.Count > 0 Then
For i = 1 To myMsg.attachments.Count
Set dict = AttachmentDict(myMsg.attachments.Item(i))
If Not dict Is Nothing Then 'check conversion happened
Body("attachments").Add dict
End If
Next
End If
json = JsonConverter.ConvertToJson(Body, Whitespace:=" ")
'...
'...
End Sub
'create a dictionary from an attachment if it meets the size limit
Function AttachmentDict(att As Outlook.Attachment)
Dim dict As Object, fso As Object, sTmpFile As String
If att.Size < MAX_ATTACHMENT Then
Set dict = CreateObject("Scripting.Dictionary")
Set fso = CreateObject("Scripting.FileSystemObject")
sTmpFile = fso.GetSpecialFolder(2) & "\" & fso.GetTempName
att.SaveAsFile sTmpFile
dict.Add att.Filename, "data:" & _
att.PropertyAccessor.GetProperty(PR_ATTACH_CONTENT_TYPE) & _
";" & "base64," & FileToBase64(sTmpFile)
Set AttachmentDict = dict
End If
End Function
Function FileToBase64(FilePath As String) As String
Const adTypeBinary = 1 ' Binary file is encoded
Dim objXML, objDocElem, objStream
' Open data stream from file
Set objStream = CreateObject("ADODB.Stream")
objStream.Type = adTypeBinary
objStream.Open
objStream.LoadFromFile FilePath
Set objXML = CreateObject("MSXml2.DOMDocument")
Set objDocElem = objXML.createElement("Base64Data")
objDocElem.DataType = "bin.base64"
objDocElem.nodeTypedValue = objStream.Read()
FileToBase64 = objDocElem.Text
End Function

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

JSON to EXCEL using VBA without external GitHub project or Power Query

I am trying to import a json file to EXCEL using VBA code but I neither want to use a GitHub project nor use Power Query but I am not able to get any proper reference on how to do it. The json string looks like this:
{
"menu": "food",
"open": "true",
"order": "true",
"food": [
{
"name": "burger",
"type": "saucy",
"id": 1,
"available": true,
"price": "3$"
},
{
"name": "pizza",
"type": "spicy",
"id": 2,
"available": true,
"price": "2$"
}
]
}
My requirement is to show it in excel with column headers as the key and the values in rows like this:
name
type
id
available
price
burger
saucy
1
true
3$
pizza
spicy
2
true
2$
This is a Regex solution which only work specifically to your JSON, the key value in your JSON file must be exactly the same as what you have provided in the question.
Your posted JSON is invalid currently as price does not have quotes so please double check and use the correct regex pattern in the code below:
Private Sub ParseFoodJSON()
Dim jsontxt As String
jsontxt = OpenTxtFile("D:/TestJSON.txt") 'Change to your JSON file path
Dim regex As Object
Set regex = CreateObject("VbScript.RegExp")
regex.Global = True
regex.Pattern = """name"":[\s]{0,}""([\w\d\s]{1,})"",[\s]{0,}""type"":[\s]{0,}""([\w\d\s]{1,})"",[\s]{0,}""id"":([\w\d\s]{1,}),[\s]{0,}""available"":([\w\d\s]{1,}),[\s]{0,}""price"":""([\w\d\s$]{1,})"""
'Use below regex if your price key really does not have quotes
'regex.Pattern = """name"":[\s]{0,}""([\w\d\s]{1,})"",[\s]{0,}""type"":[\s]{0,}""([\w\d\s]{1,})"",[\s]{0,}""id"":([\w\d\s]{1,}),[\s]{0,}""available"":([\w\d\s]{1,}),[\s]{0,}price:""([\w\d\s$]{1,})"""
If regex.test(jsontxt) Then
Dim regexColl As Object
Set regexColl = regex.Execute(jsontxt)
Dim foodArr() As Variant
ReDim foodArr(1 To regexColl.Count + 1, 1 To 5) As Variant
foodArr(1, 1) = "name"
foodArr(1, 2) = "type"
foodArr(1, 3) = "id"
foodArr(1, 4) = "available"
foodArr(1, 5) = "price"
Dim i As Long
Dim foodIndex As Long
For i = 0 To regexColl.Count - 1
foodIndex = i + 2
foodArr(foodIndex, 1) = regexColl(i).SubMatches(0)
foodArr(foodIndex, 2) = regexColl(i).SubMatches(1)
foodArr(foodIndex, 3) = regexColl(i).SubMatches(2)
foodArr(foodIndex, 4) = regexColl(i).SubMatches(3)
foodArr(foodIndex, 5) = regexColl(i).SubMatches(4)
Next i
End If
Set regexColl = Nothing
Set regex = Nothing
ActiveSheet.Cells(1, 1).Resize(UBound(foodArr, 1), UBound(foodArr, 2)).Value = foodArr
Erase foodArr
End Sub
Private Function OpenTxtFile(argPath As String) As String
Dim FSO As Scripting.FileSystemObject
Set FSO = New Scripting.FileSystemObject
Dim txtFile As TextStream
Set txtFile = FSO.OpenTextFile(argPath)
OpenTxtFile = txtFile.ReadAll
txtFile.Close
Set txtFile = Nothing
Set FSO = Nothing
End Function
Running ParseFoodJSON will parse the JSON given in OpenTxtFile (the first line) and print the result in your ActiveSheet which you will need to change to suit your purpose.

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.

Parse JSON, MS Access VBA (nested loops)

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