使用 VBA 解析 JSON 个对象和集合
Parse JSON objects and collection using VBA
我有一个 JSON 文件，其中包含：
数组（“组件”） 个对象
有些对象可能有子 array("components") 有些没有。
我需要提取那个 array 的 labels, keys 还有 array("values") 和所有 labels, values.
但是以下 VBA 代码仅适用于第一级“组件”，请勿深入研究第二级或第三级。让我知道我做对了吗？
我一直在使用 JsonConverter 解析 JSON 文件，然后使用以下代码：
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
旧 JSON 文件 - 上面的代码在这方面工作正常
{
"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
}
]
}
为了理解它我用了http://jsoneditoronline.org/尝试在下图中传达
试试这个：
https://github.com/VBA-tools/VBA-JSON
您需要在您的项目中导入文件“JsonConverter.bas”，然后按照README.md文件中的示例进行操作
请注意，我已经使用 key 作为字典键和 label 交换了字典条目，因为 label 的值不是唯一的（就样本 JSON 显示而言）并将导致错误（或覆盖以前的条目，具体取决于实现）。
应避免使用 On Error Resume Next（这适用于任何情况，除非您是故意使用它，但很少需要），因为您基本上隐藏了所有可能导致代码生成的错误意外的结果。可以在If..Else..End If语句中使用Exists方法先检查字典键是否存在，只有存在才执行任务。
编辑 - 代码已更新以处理新旧 JSON 格式
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
我有一个 JSON 文件，其中包含： 数组（“组件”） 个对象
有些对象可能有子 array("components") 有些没有。
我需要提取那个 array 的 labels, keys 还有 array("values") 和所有 labels, values.
但是以下 VBA 代码仅适用于第一级“组件”，请勿深入研究第二级或第三级。让我知道我做对了吗？
我一直在使用 JsonConverter 解析 JSON 文件，然后使用以下代码：
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
旧 JSON 文件 - 上面的代码在这方面工作正常
{
"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
}
]
}
为了理解它我用了http://jsoneditoronline.org/尝试在下图中传达
试试这个：
https://github.com/VBA-tools/VBA-JSON
您需要在您的项目中导入文件“JsonConverter.bas”，然后按照README.md文件中的示例进行操作
请注意，我已经使用 key 作为字典键和 label 交换了字典条目，因为 label 的值不是唯一的（就样本 JSON 显示而言）并将导致错误（或覆盖以前的条目，具体取决于实现）。
应避免使用 On Error Resume Next（这适用于任何情况，除非您是故意使用它，但很少需要），因为您基本上隐藏了所有可能导致代码生成的错误意外的结果。可以在If..Else..End If语句中使用Exists方法先检查字典键是否存在，只有存在才执行任务。
编辑 - 代码已更新以处理新旧 JSON 格式
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