Parse JSON objects and collection using VBA - arrays

Question

I have a JSON file which contains:
array("components") of Objects
some of objects may have sub array("components") some don't.
I need to extract the labels, keys of that array also the array("values") with all the labels, values.
HOWEVER following VBA code only work with first level of "components", do not dig into second or third levels. let me know if I am doing it right?
I have been using JsonConverter to parse JSON file and then using following code:
Dim jSon As Variant
Set jSon = JsonConverter.ParseJson(jSonText)
Dim components As Collection
Set components = jSon("components")
Set Dict = New Scripting.Dictionary
Dim component As Variant
For Each component In components
Dim Label, Key As String 'not used
Dict.Add component("label"), component("key")
On Error Resume Next
Dim Values As Collection
Set Values = component("components")
Dim Data As Scripting.Dictionary
Set Data = component("data")
On Error GoTo 0
Dim value As Variant
If Not Values Is Nothing Then
For Each value In Values
Dict.Add value("label"), value("value")
Next value
ElseIf Not Data Is Nothing Then
Set Values = Data("values")
For Each value In Values
Dict.Add value("label"), value("value")
Next value
Else
'Debug.Print " No values"
End If
Set Values = Nothing
Set Data = Nothing
Next component
OLD JSON FILE - above code is working fine on this
{
"display": "form",
"settings": {
"pdf": {
"id": "1ec0f8ee-6685-5d98-a847-26f67b67d6f0",
"src": "https://files8-a847-26f67b67d6f08-a847-26f67b67d6f0"
}
},
"components": [
{
"label": "Family Name",
"tableView": true,
"key": "familyName",
"type": "textfield",
"input": true
},
{
"label": "Amount of Money",
"mask": false,
"tableView": false,
"delimiter": false,
"requireDecimal": false,
"inputFormat": "plain",
"truncateMultipleSpaces": false,
"key": "amountOfMoney",
"type": "number",
"input": true
},
{
"label": "I hereby confirm",
"tableView": false,
"key": "iHerebyConfirm",
"type": "checkbox",
"input": true,
"defaultValue": false
},
{
"label": "Which Cities do you like",
"optionsLabelPosition": "right",
"tableView": false,
"values": [
{
"label": "New York",
"value": "newNew YorkYork",
"shortcut": ""
},
{
"label": "Munich",
"value": "Munich",
"shortcut": ""
},
{
"label": "Paris",
"value": "Paris",
"shortcut": ""
},
{
"label": "Hongkong",
"value": "Hongkong",
"shortcut": ""
},
{
"label": "Mumbai",
"value": "Mumbai",
"shortcut": ""
}
],
"key": "whichCitiesDoYouLike",
"type": "selectboxes",
"input": true,
"inputType": "checkbox"
},
{
"label": "Favorite color",
"widget": "choicesjs",
"tableView": true,
"data": {
"values": [
{
"label": "black",
"value": "black"
},
{
"label": "white",
"value": "white"
},
{
"label": "blue",
"value": "blue"
},
{
"label": "green",
"value": "green"
}
]
},
"key": "favoriteColor",
"type": "select",
"input": true
},
{
"type": "button",
"label": "Submit",
"key": "submit",
"disableOnInvalid": true,
"input": true,
"tableView": false
}
]
}
To understand it I used http://jsoneditoronline.org/ try to convey in following picture

Answer 1

Take note that I have swapped the dictionary entry using key as the dictionary key and label as the value as label is not unique (as far as the sample JSON shows) and will cause an error (or overwrite previous entry, depending on implementation).
Your usage of On Error Resume Next should be avoided (this applies to any scenario, unless you are using it on purpose which is rarely needed) as you are basically hiding all possible errors which can cause your code to produce unintended result. You can use Exists method in If..Else..End If statement to check if the dictionary key exist first and only perform the task if it do exist.
EDIT - Code updated to handle both old and new JSON format
Private Sub Test()
'==== Change this part according to your implementation..."
Dim jsontxt As String
jsontxt = OpenTxtFile("D:/TestJSON2.txt")
'====
Dim jSon As Scripting.Dictionary
Set jSon = JsonConverter.ParseJson(jsontxt)
'Check if first level of components exist and get the collection of components if true
If jSon.Exists("components") Then
Dim components As Collection
Set components = jSon("components")
Dim Dict As Scripting.Dictionary
Set Dict = New Scripting.Dictionary
Dim comFirst As Variant
Dim comSecond As Variant
Dim comThird As Variant
Dim columnsDict As Variant
Dim valDict As Variant
For Each comFirst In components
'extract key-label from first level component
If Not Dict.Exists(comFirst("label")) Then Dict.Add comFirst("label"), comFirst("key")
'++++ New JSON Format ++++
'==== Check if second level of "components" key exist and extract label-key if true
If comFirst.Exists("components") Then
For Each comSecond In comFirst("components")
If Not Dict.Exists(comSecond("label")) Then Dict.Add comSecond("label"), comSecond("key")
'=== Check if "columns" key exist and extract the key-label if true
If comSecond.Exists("columns") Then
For Each columnsDict In comSecond("columns")
'==== Check if third level of "components" key exist and extract key-label if true
If columnsDict.Exists("components") Then
For Each comThird In columnsDict("components")
If Not Dict.Exists(comThird("label")) Then Dict.Add comThird("label"), comThird("key")
'==== Check if "values" key exist and extract label-value if true
If comThird.Exists("values") Then
For Each valDict In comThird("values")
If Not Dict.Exists(valDict("label")) Then Dict.Add valDict("label"), valDict("value")
Next valDict
End If
'====
Next comThird
End If
'====
Next columnsDict
End If
'====
'==== Check if "values" key exist and extract the label-value if true
If comSecond.Exists("values") Then
For Each valDict In comSecond("values")
If Not Dict.Exists(valDict("label")) Then Dict.Add valDict("label"), valDict("value")
Next valDict
End If
'====
Next comSecond
End If
'++++
'++++ Old JSON format ++++
'==== Check if "data" key exist and extract the label-value if true
If comFirst.Exists("data") Then
If comFirst("data").Exists("values") Then
For Each valDict In comFirst("data")("values")
If Not Dict.Exists(valDict("label")) Then Dict.Add valDict("label"), valDict("value")
Next valDict
End If
End If
'====
'==== Check if "values" key exist and extract the label-value if true
If comFirst.Exists("values") Then
For Each valDict In comFirst("values")
If Not Dict.Exists(valDict("label")) Then Dict.Add valDict("label"), valDict("value")
Next valDict
End If
'====
'++++
Next comFirst
End If
End Sub

Answer 2

Try this:
https://github.com/VBA-tools/VBA-JSON
You need to import the file "JsonConverter.bas" in your project and then follow the examples in the README.md file