我有与Excel VBA中相同的问题：解析JSON对象循环，但找不到任何解决方案。我的JSON具有嵌套对象，因此建议的解决方案（如VBJSON和vba-json）不适用于我。我还修复了其中之一，使其正常工作，但是由于doProcess函数的许多递归，结果是调用堆栈溢出。
最好的解决方案似乎是原始帖子中看到的jsonDecode函数。它非常快速并且非常有效。我的对象结构全部位于类型JScriptTypeInfo的通用VBA对象中。
此时的问题是，我无法确定对象的结构，因此，我事先不知道将驻留在每个通用对象中的键。我需要遍历通用VBA对象以获取键/属性。
如果我的解析javascript函数可以触发VBA函数或sub，那就太好了。
Answers:
如果要在的基础上构建ScriptControl，则可以添加一些帮助程序方法以获取所需的信息。该JScriptTypeInfo对象有点不幸：它包含所有相关信息（如您在“监视”窗口中看到的那样），但似乎无法使用VBA来实现。但是，JavaScript引擎可以帮助我们：
Option Explicit
Private ScriptEngine As ScriptControl
Public Sub InitScriptEngine()
Set ScriptEngine = New ScriptControl
ScriptEngine.Language = "JScript"
ScriptEngine.AddCode "function getProperty(jsonObj, propertyName) { return jsonObj[propertyName]; } "
ScriptEngine.AddCode "function getKeys(jsonObj) { var keys = new Array(); for (var i in jsonObj) { keys.push(i); } return keys; } "
End Sub
Public Function DecodeJsonString(ByVal JsonString As String)
Set DecodeJsonString = ScriptEngine.Eval("(" + JsonString + ")")
End Function
Public Function GetProperty(ByVal JsonObject As Object, ByVal propertyName As String) As Variant
GetProperty = ScriptEngine.Run("getProperty", JsonObject, propertyName)
End Function
Public Function GetObjectProperty(ByVal JsonObject As Object, ByVal propertyName As String) As Object
Set GetObjectProperty = ScriptEngine.Run("getProperty", JsonObject, propertyName)
End Function
Public Function GetKeys(ByVal JsonObject As Object) As String()
Dim Length As Integer
Dim KeysArray() As String
Dim KeysObject As Object
Dim Index As Integer
Dim Key As Variant
Set KeysObject = ScriptEngine.Run("getKeys", JsonObject)
Length = GetProperty(KeysObject, "length")
ReDim KeysArray(Length - 1)
Index = 0
For Each Key In KeysObject
KeysArray(Index) = Key
Index = Index + 1
Next
GetKeys = KeysArray
End Function
Public Sub TestJsonAccess()
Dim JsonString As String
Dim JsonObject As Object
Dim Keys() As String
Dim Value As Variant
Dim j As Variant
InitScriptEngine
JsonString = "{""key1"": ""val1"", ""key2"": { ""key3"": ""val3"" } }"
Set JsonObject = DecodeJsonString(CStr(JsonString))
Keys = GetKeys(JsonObject)
Value = GetProperty(JsonObject, "key1")
Set Value = GetObjectProperty(JsonObject, "key2")
End Sub
一些注意事项：
JScriptTypeInfo实例引用了Javascript对象，For Each ... Next则将无法使用。但是，如果它引用Javascript数组，则它确实起作用（请参见GetKeys函数）。GetProperty和GetObjectProperty。length，0，Item 0，1，Item 1等有了VBA点符号（jsonObject.property），只有length属性访问，则只有声明一个变量叫length所有的小写字母。否则，案例将不匹配，并且找不到。其他属性在VBA中无效。因此最好使用该GetProperty功能。InitScriptEngine在使用其他功能进行一些基本初始化之前，您必须调用一次。object variable not set尝试该DecodeJsonString功能时却遇到了问题。除了Microsoft脚本控制外，我还需要其他参考吗？
Set DecodeJsonString = ScriptEngine.Eval("(" + JsonString + ")")。该JsonString仅仅是一个普通的JSON对象。我已经尝试了多种Json对象，并得到了相同的错误。
Set se = CreateObject("MSScriptControl.ScriptControl")。+1谢谢！
更新3（17年9月24日）
在GitHub上检查VBA-JSON-parser以获取最新版本和示例。将JSON.bas模块导入VBA项目以进行JSON处理。
更新2（16年10月1日）
但是，如果您确实想使用来解析64位Office上的JSON ScriptControl，那么此答案可能会帮助您开始ScriptControl在64位上工作。
更新（2015年10月26日）
请注意，ScriptControl基于方法的方法在某些情况下会使系统容易受到攻击，因为它们允许通过ActiveX直接访问恶意JS代码的驱动器（和其他内容）。假设您正在解析Web服务器响应JSON，例如JsonString = "{a:(function(){(new ActiveXObject('Scripting.FileSystemObject')).CreateTextFile('C:\\Test.txt')})()}"。经过评估，您将找到新创建的文件C:\Test.txt。因此，使用ScriptControlActiveX进行JSON解析不是一个好主意。
为了避免这种情况，我基于RegEx创建了JSON解析器。对象{}是通过字典来表示，这使得可以使用字典的属性和方法：.Count，.Exists()，.Item()，.Items，.Keys。数组[]是常规的从零开始的VB数组，因此UBound()显示了元素数。这是带有一些用法示例的代码：
Option Explicit
Sub JsonTest()
Dim strJsonString As String
Dim varJson As Variant
Dim strState As String
Dim varItem As Variant
' parse JSON string to object
' root element can be the object {} or the array []
strJsonString = "{""a"":[{}, 0, ""value"", [{""stuff"":""content""}]], b:null}"
ParseJson strJsonString, varJson, strState
' checking the structure step by step
Select Case False ' if any of the checks is False, the sequence is interrupted
Case IsObject(varJson) ' if root JSON element is object {},
Case varJson.Exists("a") ' having property a,
Case IsArray(varJson("a")) ' which is array,
Case UBound(varJson("a")) >= 3 ' having not less than 4 elements,
Case IsArray(varJson("a")(3)) ' where forth element is array,
Case UBound(varJson("a")(3)) = 0 ' having the only element,
Case IsObject(varJson("a")(3)(0)) ' which is object,
Case varJson("a")(3)(0).Exists("stuff") ' having property stuff,
Case Else
MsgBox "Check the structure step by step" & vbCrLf & varJson("a")(3)(0)("stuff") ' then show the value of the last one property.
End Select
' direct access to the property if sure of structure
MsgBox "Direct access to the property" & vbCrLf & varJson.Item("a")(3)(0).Item("stuff") ' content
' traversing each element in array
For Each varItem In varJson("a")
' show the structure of the element
MsgBox "The structure of the element:" & vbCrLf & BeautifyJson(varItem)
Next
' show the full structure starting from root element
MsgBox "The full structure starting from root element:" & vbCrLf & BeautifyJson(varJson)
End Sub
Sub BeautifyTest()
' put sourse JSON string to "desktop\source.json" file
' processed JSON will be saved to "desktop\result.json" file
Dim strDesktop As String
Dim strJsonString As String
Dim varJson As Variant
Dim strState As String
Dim strResult As String
Dim lngIndent As Long
strDesktop = CreateObject("WScript.Shell").SpecialFolders.Item("Desktop")
strJsonString = ReadTextFile(strDesktop & "\source.json", -2)
ParseJson strJsonString, varJson, strState
If strState <> "Error" Then
strResult = BeautifyJson(varJson)
WriteTextFile strResult, strDesktop & "\result.json", -1
End If
CreateObject("WScript.Shell").PopUp strState, 1, , 64
End Sub
Sub ParseJson(ByVal strContent As String, varJson As Variant, strState As String)
' strContent - source JSON string
' varJson - created object or array to be returned as result
' strState - Object|Array|Error depending on processing to be returned as state
Dim objTokens As Object
Dim objRegEx As Object
Dim bMatched As Boolean
Set objTokens = CreateObject("Scripting.Dictionary")
Set objRegEx = CreateObject("VBScript.RegExp")
With objRegEx
' specification http://www.json.org/
.Global = True
.MultiLine = True
.IgnoreCase = True
.Pattern = """(?:\\""|[^""])*""(?=\s*(?:,|\:|\]|\}))"
Tokenize objTokens, objRegEx, strContent, bMatched, "str"
.Pattern = "(?:[+-])?(?:\d+\.\d*|\.\d+|\d+)e(?:[+-])?\d+(?=\s*(?:,|\]|\}))"
Tokenize objTokens, objRegEx, strContent, bMatched, "num"
.Pattern = "(?:[+-])?(?:\d+\.\d*|\.\d+|\d+)(?=\s*(?:,|\]|\}))"
Tokenize objTokens, objRegEx, strContent, bMatched, "num"
.Pattern = "\b(?:true|false|null)(?=\s*(?:,|\]|\}))"
Tokenize objTokens, objRegEx, strContent, bMatched, "cst"
.Pattern = "\b[A-Za-z_]\w*(?=\s*\:)" ' unspecified name without quotes
Tokenize objTokens, objRegEx, strContent, bMatched, "nam"
.Pattern = "\s"
strContent = .Replace(strContent, "")
.MultiLine = False
Do
bMatched = False
.Pattern = "<\d+(?:str|nam)>\:<\d+(?:str|num|obj|arr|cst)>"
Tokenize objTokens, objRegEx, strContent, bMatched, "prp"
.Pattern = "\{(?:<\d+prp>(?:,<\d+prp>)*)?\}"
Tokenize objTokens, objRegEx, strContent, bMatched, "obj"
.Pattern = "\[(?:<\d+(?:str|num|obj|arr|cst)>(?:,<\d+(?:str|num|obj|arr|cst)>)*)?\]"
Tokenize objTokens, objRegEx, strContent, bMatched, "arr"
Loop While bMatched
.Pattern = "^<\d+(?:obj|arr)>$" ' unspecified top level array
If Not (.Test(strContent) And objTokens.Exists(strContent)) Then
varJson = Null
strState = "Error"
Else
Retrieve objTokens, objRegEx, strContent, varJson
strState = IIf(IsObject(varJson), "Object", "Array")
End If
End With
End Sub
Sub Tokenize(objTokens, objRegEx, strContent, bMatched, strType)
Dim strKey As String
Dim strRes As String
Dim lngCopyIndex As Long
Dim objMatch As Object
strRes = ""
lngCopyIndex = 1
With objRegEx
For Each objMatch In .Execute(strContent)
strKey = "<" & objTokens.Count & strType & ">"
bMatched = True
With objMatch
objTokens(strKey) = .Value
strRes = strRes & Mid(strContent, lngCopyIndex, .FirstIndex - lngCopyIndex + 1) & strKey
lngCopyIndex = .FirstIndex + .Length + 1
End With
Next
strContent = strRes & Mid(strContent, lngCopyIndex, Len(strContent) - lngCopyIndex + 1)
End With
End Sub
Sub Retrieve(objTokens, objRegEx, strTokenKey, varTransfer)
Dim strContent As String
Dim strType As String
Dim objMatches As Object
Dim objMatch As Object
Dim strName As String
Dim varValue As Variant
Dim objArrayElts As Object
strType = Left(Right(strTokenKey, 4), 3)
strContent = objTokens(strTokenKey)
With objRegEx
.Global = True
Select Case strType
Case "obj"
.Pattern = "<\d+\w{3}>"
Set objMatches = .Execute(strContent)
Set varTransfer = CreateObject("Scripting.Dictionary")
For Each objMatch In objMatches
Retrieve objTokens, objRegEx, objMatch.Value, varTransfer
Next
Case "prp"
.Pattern = "<\d+\w{3}>"
Set objMatches = .Execute(strContent)
Retrieve objTokens, objRegEx, objMatches(0).Value, strName
Retrieve objTokens, objRegEx, objMatches(1).Value, varValue
If IsObject(varValue) Then
Set varTransfer(strName) = varValue
Else
varTransfer(strName) = varValue
End If
Case "arr"
.Pattern = "<\d+\w{3}>"
Set objMatches = .Execute(strContent)
Set objArrayElts = CreateObject("Scripting.Dictionary")
For Each objMatch In objMatches
Retrieve objTokens, objRegEx, objMatch.Value, varValue
If IsObject(varValue) Then
Set objArrayElts(objArrayElts.Count) = varValue
Else
objArrayElts(objArrayElts.Count) = varValue
End If
varTransfer = objArrayElts.Items
Next
Case "nam"
varTransfer = strContent
Case "str"
varTransfer = Mid(strContent, 2, Len(strContent) - 2)
varTransfer = Replace(varTransfer, "\""", """")
varTransfer = Replace(varTransfer, "\\", "\")
varTransfer = Replace(varTransfer, "\/", "/")
varTransfer = Replace(varTransfer, "\b", Chr(8))
varTransfer = Replace(varTransfer, "\f", Chr(12))
varTransfer = Replace(varTransfer, "\n", vbLf)
varTransfer = Replace(varTransfer, "\r", vbCr)
varTransfer = Replace(varTransfer, "\t", vbTab)
.Global = False
.Pattern = "\\u[0-9a-fA-F]{4}"
Do While .Test(varTransfer)
varTransfer = .Replace(varTransfer, ChrW(("&H" & Right(.Execute(varTransfer)(0).Value, 4)) * 1))
Loop
Case "num"
varTransfer = Evaluate(strContent)
Case "cst"
Select Case LCase(strContent)
Case "true"
varTransfer = True
Case "false"
varTransfer = False
Case "null"
varTransfer = Null
End Select
End Select
End With
End Sub
Function BeautifyJson(varJson As Variant) As String
Dim strResult As String
Dim lngIndent As Long
BeautifyJson = ""
lngIndent = 0
BeautyTraverse BeautifyJson, lngIndent, varJson, vbTab, 1
End Function
Sub BeautyTraverse(strResult As String, lngIndent As Long, varElement As Variant, strIndent As String, lngStep As Long)
Dim arrKeys() As Variant
Dim lngIndex As Long
Dim strTemp As String
Select Case VarType(varElement)
Case vbObject
If varElement.Count = 0 Then
strResult = strResult & "{}"
Else
strResult = strResult & "{" & vbCrLf
lngIndent = lngIndent + lngStep
arrKeys = varElement.Keys
For lngIndex = 0 To UBound(arrKeys)
strResult = strResult & String(lngIndent, strIndent) & """" & arrKeys(lngIndex) & """" & ": "
BeautyTraverse strResult, lngIndent, varElement(arrKeys(lngIndex)), strIndent, lngStep
If Not (lngIndex = UBound(arrKeys)) Then strResult = strResult & ","
strResult = strResult & vbCrLf
Next
lngIndent = lngIndent - lngStep
strResult = strResult & String(lngIndent, strIndent) & "}"
End If
Case Is >= vbArray
If UBound(varElement) = -1 Then
strResult = strResult & "[]"
Else
strResult = strResult & "[" & vbCrLf
lngIndent = lngIndent + lngStep
For lngIndex = 0 To UBound(varElement)
strResult = strResult & String(lngIndent, strIndent)
BeautyTraverse strResult, lngIndent, varElement(lngIndex), strIndent, lngStep
If Not (lngIndex = UBound(varElement)) Then strResult = strResult & ","
strResult = strResult & vbCrLf
Next
lngIndent = lngIndent - lngStep
strResult = strResult & String(lngIndent, strIndent) & "]"
End If
Case vbInteger, vbLong, vbSingle, vbDouble
strResult = strResult & varElement
Case vbNull
strResult = strResult & "Null"
Case vbBoolean
strResult = strResult & IIf(varElement, "True", "False")
Case Else
strTemp = Replace(varElement, "\""", """")
strTemp = Replace(strTemp, "\", "\\")
strTemp = Replace(strTemp, "/", "\/")
strTemp = Replace(strTemp, Chr(8), "\b")
strTemp = Replace(strTemp, Chr(12), "\f")
strTemp = Replace(strTemp, vbLf, "\n")
strTemp = Replace(strTemp, vbCr, "\r")
strTemp = Replace(strTemp, vbTab, "\t")
strResult = strResult & """" & strTemp & """"
End Select
End Sub
Function ReadTextFile(strPath As String, lngFormat As Long) As String
' lngFormat -2 - System default, -1 - Unicode, 0 - ASCII
With CreateObject("Scripting.FileSystemObject").OpenTextFile(strPath, 1, False, lngFormat)
ReadTextFile = ""
If Not .AtEndOfStream Then ReadTextFile = .ReadAll
.Close
End With
End Function
Sub WriteTextFile(strContent As String, strPath As String, lngFormat As Long)
With CreateObject("Scripting.FileSystemObject").OpenTextFile(strPath, 2, True, lngFormat)
.Write (strContent)
.Close
End With
End Sub
JSON RegEx解析器的另一个机会是，它可以在64位Office上运行，而ScriptControl不可用。
初始（15年5月27日）
这是基于ScriptControlActiveX的另一种在VBA中解析JSON的方法，无需外部库：
Sub JsonTest()
Dim Dict, Temp, Text, Keys, Items
' Converting JSON string to appropriate nested dictionaries structure
' Dictionaries have numeric keys for JSON Arrays, and string keys for JSON Objects
' Returns Nothing in case of any JSON syntax issues
Set Dict = GetJsonDict("{a:[[{stuff:'result'}]], b:''}")
' You can use For Each ... Next and For ... Next loops through keys and items
Keys = Dict.Keys
Items = Dict.Items
' Referring directly to the necessary property if sure, without any checks
MsgBox Dict("a")(0)(0)("stuff")
' Auxiliary DrillDown() function
' Drilling down the structure, sequentially checking if each level exists
Select Case False
Case DrillDown(Dict, "a", Temp, "")
Case DrillDown(Temp, 0, Temp, "")
Case DrillDown(Temp, 0, Temp, "")
Case DrillDown(Temp, "stuff", "", Text)
Case Else
' Structure is consistent, requested value found
MsgBox Text
End Select
End Sub
Function GetJsonDict(JsonString As String)
With CreateObject("ScriptControl")
.Language = "JScript"
.ExecuteStatement "function gettype(sample) {return {}.toString.call(sample).slice(8, -1)}"
.ExecuteStatement "function evaljson(json, er) {try {var sample = eval('(' + json + ')'); var type = gettype(sample); if(type != 'Array' && type != 'Object') {return er;} else {return getdict(sample);}} catch(e) {return er;}}"
.ExecuteStatement "function getdict(sample) {var type = gettype(sample); if(type != 'Array' && type != 'Object') return sample; var dict = new ActiveXObject('Scripting.Dictionary'); if(type == 'Array') {for(var key = 0; key < sample.length; key++) {dict.add(key, getdict(sample[key]));}} else {for(var key in sample) {dict.add(key, getdict(sample[key]));}} return dict;}"
Set GetJsonDict = .Run("evaljson", JsonString, Nothing)
End With
End Function
Function DrillDown(Source, Prop, Target, Value)
Select Case False
Case TypeName(Source) = "Dictionary"
Case Source.exists(Prop)
Case Else
Select Case True
Case TypeName(Source(Prop)) = "Dictionary"
Set Target = Source(Prop)
Value = Empty
Case IsObject(Source(Prop))
Set Value = Source(Prop)
Set Target = Nothing
Case Else
Value = Source(Prop)
Set Target = Nothing
End Select
DrillDown = True
Exit Function
End Select
DrillDown = False
End Function
varJson和strState被传递ByRef，值在中分配给它们Sub ParseJson()，并作为解析结果返回。
由于Json只是字符串而已，因此，只要我们能够以正确的方式对其进行操作，无论结构多么复杂，都可以轻松地对其进行处理。我认为没有必要使用任何外部库或转换器来解决问题。这是我使用字符串操作解析json数据的示例。
Sub FetchData()
Dim str As Variant, N&, R&
With New XMLHTTP60
.Open "GET", "https://oresapp.asicanada.net/ores.imis.services/api/member/?address=&callback=angular.callbacks._0&city=&companyName=&personName=", False
.send
str = Split(.responseText, ":[{""Id"":")
End With
N = UBound(str)
For R = 1 To N
Cells(R, 1) = Split(Split(str(R), "FullName"":""")(1), """")(0)
Cells(R, 2) = Split(Split(str(R), "Phone"":""")(1), """")(0)
Cells(R, 3) = Split(Split(str(R), "Email"":""")(1), """")(0)
Next R
End Sub
Split(<string>, <delimiter>, 2)在需要单个结果的循环内添加第三个参数可以提高性能。
您可以在VB代码中使用array.myitem（0）的更简单方法
在js中使用'this'对象
ScriptEngine.AddCode "Object.prototype.myitem=function( i ) { return this[i] } ; "
然后你可以去array.myitem（0）
Private ScriptEngine As ScriptControl
Public Sub InitScriptEngine()
Set ScriptEngine = New ScriptControl
ScriptEngine.Language = "JScript"
ScriptEngine.AddCode "Object.prototype.myitem=function( i ) { return this[i] } ; "
Set foo = ScriptEngine.Eval("(" + "[ 1234, 2345 ]" + ")") ' JSON array
Debug.Print foo.myitem(1) ' method case sensitive!
Set foo = ScriptEngine.Eval("(" + "{ ""key1"":23 , ""key2"":2345 }" + ")") ' JSON key value
Debug.Print foo.myitem("key1") ' WTF
End Sub
为了在VBA中解析JSON而不向工作簿项目添加巨大的库，我创建了以下解决方案。它非常快速，并且将所有键和值存储在字典中以便于访问：
Function ParseJSON(json$, Optional key$ = "obj") As Object
p = 1
token = Tokenize(json)
Set dic = CreateObject("Scripting.Dictionary")
If token(p) = "{" Then ParseObj key Else ParseArr key
Set ParseJSON = dic
End Function
Function ParseObj(key$)
Do: p = p + 1
Select Case token(p)
Case "]"
Case "[": ParseArr key
Case "{"
If token(p + 1) = "}" Then
p = p + 1
dic.Add key, "null"
Else
ParseObj key
End If
Case "}": key = ReducePath(key): Exit Do
Case ":": key = key & "." & token(p - 1)
Case ",": key = ReducePath(key)
Case Else: If token(p + 1) <> ":" Then dic.Add key, token(p)
End Select
Loop
End Function
Function ParseArr(key$)
Dim e&
Do: p = p + 1
Select Case token(p)
Case "}"
Case "{": ParseObj key & ArrayID(e)
Case "[": ParseArr key
Case "]": Exit Do
Case ":": key = key & ArrayID(e)
Case ",": e = e + 1
Case Else: dic.Add key & ArrayID(e), token(p)
End Select
Loop
End Function
上面的代码确实使用了一些辅助函数，但是上面是它的实质。
这里使用的策略是采用递归标记器。我发现足够有趣，可以在Medium上撰写有关此解决方案的文章。详细说明。
这是完整的（但很短的）代码清单，其中包括所有辅助功能：
'-------------------------------------------------------------------
' VBA JSON Parser
'-------------------------------------------------------------------
Option Explicit
Private p&, token, dic
Function ParseJSON(json$, Optional key$ = "obj") As Object
p = 1
token = Tokenize(json)
Set dic = CreateObject("Scripting.Dictionary")
If token(p) = "{" Then ParseObj key Else ParseArr key
Set ParseJSON = dic
End Function
Function ParseObj(key$)
Do: p = p + 1
Select Case token(p)
Case "]"
Case "[": ParseArr key
Case "{"
If token(p + 1) = "}" Then
p = p + 1
dic.Add key, "null"
Else
ParseObj key
End If
Case "}": key = ReducePath(key): Exit Do
Case ":": key = key & "." & token(p - 1)
Case ",": key = ReducePath(key)
Case Else: If token(p + 1) <> ":" Then dic.Add key, token(p)
End Select
Loop
End Function
Function ParseArr(key$)
Dim e&
Do: p = p + 1
Select Case token(p)
Case "}"
Case "{": ParseObj key & ArrayID(e)
Case "[": ParseArr key
Case "]": Exit Do
Case ":": key = key & ArrayID(e)
Case ",": e = e + 1
Case Else: dic.Add key & ArrayID(e), token(p)
End Select
Loop
End Function
'-------------------------------------------------------------------
' Support Functions
'-------------------------------------------------------------------
Function Tokenize(s$)
Const Pattern = """(([^""\\]|\\.)*)""|[+\-]?(?:0|[1-9]\d*)(?:\.\d*)?(?:[eE][+\-]?\d+)?|\w+|[^\s""']+?"
Tokenize = RExtract(s, Pattern, True)
End Function
Function RExtract(s$, Pattern, Optional bGroup1Bias As Boolean, Optional bGlobal As Boolean = True)
Dim c&, m, n, v
With CreateObject("vbscript.regexp")
.Global = bGlobal
.MultiLine = False
.IgnoreCase = True
.Pattern = Pattern
If .TEST(s) Then
Set m = .Execute(s)
ReDim v(1 To m.Count)
For Each n In m
c = c + 1
v(c) = n.value
If bGroup1Bias Then If Len(n.submatches(0)) Or n.value = """""" Then v(c) = n.submatches(0)
Next
End If
End With
RExtract = v
End Function
Function ArrayID$(e)
ArrayID = "(" & e & ")"
End Function
Function ReducePath$(key$)
If InStr(key, ".") Then ReducePath = Left(key, InStrRev(key, ".") - 1)
End Function
Function ListPaths(dic)
Dim s$, v
For Each v In dic
s = s & v & " --> " & dic(v) & vbLf
Next
Debug.Print s
End Function
Function GetFilteredValues(dic, match)
Dim c&, i&, v, w
v = dic.keys
ReDim w(1 To dic.Count)
For i = 0 To UBound(v)
If v(i) Like match Then
c = c + 1
w(c) = dic(v(i))
End If
Next
ReDim Preserve w(1 To c)
GetFilteredValues = w
End Function
Function GetFilteredTable(dic, cols)
Dim c&, i&, j&, v, w, z
v = dic.keys
z = GetFilteredValues(dic, cols(0))
ReDim w(1 To UBound(z), 1 To UBound(cols) + 1)
For j = 1 To UBound(cols) + 1
z = GetFilteredValues(dic, cols(j - 1))
For i = 1 To UBound(z)
w(i, j) = z(i)
Next
Next
GetFilteredTable = w
End Function
Function OpenTextFile$(f)
With CreateObject("ADODB.Stream")
.Charset = "utf-8"
.Open
.LoadFromFile f
OpenTextFile = .ReadText
End With
End Function
这在Excel和使用JSON查询转换为本机形式的大型JSON文件下适用于我。 https://github.com/VBA-tools/VBA-JSON 我能够解析“ item.something”之类的节点并使用简单的命令获得价值：
MsgBox Json("item")("something")
太好了
非常感谢Codo。
我刚刚更新并完成了您所做的事情：
添加，删除和更新节点（已知）
Option Explicit
Private ScriptEngine As ScriptControl
Public Sub InitScriptEngine()
Set ScriptEngine = New ScriptControl
ScriptEngine.Language = "JScript"
ScriptEngine.AddCode "function getProperty(jsonObj, propertyName) { return jsonObj[propertyName]; } "
ScriptEngine.AddCode "function getType(jsonObj, propertyName) {return typeof(jsonObj[propertyName]);}"
ScriptEngine.AddCode "function getKeys(jsonObj) { var keys = new Array(); for (var i in jsonObj) { keys.push(i); } return keys; } "
ScriptEngine.AddCode "function addKey(jsonObj, propertyName, value) { jsonObj[propertyName] = value; return jsonObj;}"
ScriptEngine.AddCode "function removeKey(jsonObj, propertyName) { var json = jsonObj; delete json[propertyName]; return json }"
End Sub
Public Function removeJSONProperty(ByVal JsonObject As Object, propertyName As String)
Set removeJSONProperty = ScriptEngine.Run("removeKey", JsonObject, propertyName)
End Function
Public Function updateJSONPropertyValue(ByVal JsonObject As Object, propertyName As String, value As String) As Object
Set updateJSONPropertyValue = ScriptEngine.Run("removeKey", JsonObject, propertyName)
Set updateJSONPropertyValue = ScriptEngine.Run("addKey", JsonObject, propertyName, value)
End Function
Public Function addJSONPropertyValue(ByVal JsonObject As Object, propertyName As String, value As String) As Object
Set addJSONPropertyValue = ScriptEngine.Run("addKey", JsonObject, propertyName, value)
End Function
Public Function DecodeJsonString(ByVal JsonString As String)
InitScriptEngine
Set DecodeJsonString = ScriptEngine.Eval("(" + JsonString + ")")
End Function
Public Function GetProperty(ByVal JsonObject As Object, ByVal propertyName As String) As Variant
GetProperty = ScriptEngine.Run("getProperty", JsonObject, propertyName)
End Function
Public Function GetObjectProperty(ByVal JsonObject As Object, ByVal propertyName As String) As Object
Set GetObjectProperty = ScriptEngine.Run("getProperty", JsonObject, propertyName)
End Function
Public Function SerializeJSONObject(ByVal JsonObject As Object) As String()
Dim Length As Integer
Dim KeysArray() As String
Dim KeysObject As Object
Dim Index As Integer
Dim Key As Variant
Dim tmpString As String
Dim tmpJSON As Object
Dim tmpJSONArray() As Variant
Dim tmpJSONObject() As Variant
Dim strJsonObject As String
Dim tmpNbElement As Long, i As Long
InitScriptEngine
Set KeysObject = ScriptEngine.Run("getKeys", JsonObject)
Length = GetProperty(KeysObject, "length")
ReDim KeysArray(Length - 1)
Index = 0
For Each Key In KeysObject
tmpString = ""
If ScriptEngine.Run("getType", JsonObject, Key) = "object" Then
'MsgBox "object " & SerializeJSONObject(GetObjectProperty(JsonObject, Key))(0)
Set tmpJSON = GetObjectProperty(JsonObject, Key)
strJsonObject = VBA.Replace(ScriptEngine.Run("getKeys", tmpJSON), " ", "")
tmpNbElement = Len(strJsonObject) - Len(VBA.Replace(strJsonObject, ",", ""))
If VBA.IsNumeric(Left(ScriptEngine.Run("getKeys", tmpJSON), 1)) = True Then
ReDim tmpJSONArray(tmpNbElement)
For i = 0 To tmpNbElement
tmpJSONArray(i) = GetProperty(tmpJSON, i)
Next
tmpString = "[" & Join(tmpJSONArray, ",") & "]"
Else
tmpString = "{" & Join(SerializeJSONObject(tmpJSON), ", ") & "}"
End If
Else
tmpString = GetProperty(JsonObject, Key)
End If
KeysArray(Index) = Key & ": " & tmpString
Index = Index + 1
Next
SerializeJSONObject = KeysArray
End Function
Public Function GetKeys(ByVal JsonObject As Object) As String()
Dim Length As Integer
Dim KeysArray() As String
Dim KeysObject As Object
Dim Index As Integer
Dim Key As Variant
InitScriptEngine
Set KeysObject = ScriptEngine.Run("getKeys", JsonObject)
Length = GetProperty(KeysObject, "length")
ReDim KeysArray(Length - 1)
Index = 0
For Each Key In KeysObject
KeysArray(Index) = Key
Index = Index + 1
Next
GetKeys = KeysArray
End Function
Microsoft：由于VBScript是Visual Basic for Applications的子集，因此...
下面的代码来自Codo的帖子，以类的形式使用也很有用，并且可用作VBScript：
class JsonParser
' adapted from: http://stackoverflow.com/questions/6627652/parsing-json-in-excel-vba
private se
private sub Class_Initialize
set se = CreateObject("MSScriptControl.ScriptControl")
se.Language = "JScript"
se.AddCode "function getValue(jsonObj, valueName) { return jsonObj[valueName]; } "
se.AddCode "function enumKeys(jsonObj) { var keys = new Array(); for (var i in jsonObj) { keys.push(i); } return keys; } "
end sub
public function Decode(ByVal json)
set Decode = se.Eval("(" + cstr(json) + ")")
end function
public function GetValue(ByVal jsonObj, ByVal valueName)
GetValue = se.Run("getValue", jsonObj, valueName)
end function
public function GetObject(ByVal jsonObject, ByVal valueName)
set GetObjet = se.Run("getValue", jsonObject, valueName)
end function
public function EnumKeys(ByVal jsonObject)
dim length, keys, obj, idx, key
set obj = se.Run("enumKeys", jsonObject)
length = GetValue(obj, "length")
redim keys(length - 1)
idx = 0
for each key in obj
keys(idx) = key
idx = idx + 1
next
EnumKeys = keys
end function
end class
用法：
set jp = new JsonParser
set jo = jp.Decode("{value: true}")
keys = jp.EnumKeys(jo)
value = jp.GetValue(jo, "value")
另一个基于Regex的JSON解析器（仅解码）
Private Enum JsonStep
jsonString
jsonNumber
jsonTrue
jsonFalse
jsonNull
jsonOpeningBrace
jsonClosingBrace
jsonOpeningBracket
jsonClosingBracket
jsonComma
jsonColon
End Enum
Private regexp As Object
Private Function JsonStepName(ByVal json_step As JsonStep) As String
Select Case json_step
Case jsonString: JsonStepName = "'STRING'"
Case jsonNumber: JsonStepName = "'NUMBER'"
Case jsonTrue: JsonStepName = "true"
Case jsonFalse: JsonStepName = "false"
Case jsonNull: JsonStepName = "null"
Case jsonOpeningBrace: JsonStepName = "'{'"
Case jsonClosingBrace: JsonStepName = "'}'"
Case jsonOpeningBracket: JsonStepName = "'['"
Case jsonClosingBracket: JsonStepName = "']'"
Case jsonComma: JsonStepName = "','"
Case jsonColon: JsonStepName = "':'"
End Select
End Function
Private Function Unescape(ByVal str As String) As String
Dim match As Object
str = Replace$(str, "\""", """")
str = Replace$(str, "\\", "\")
str = Replace$(str, "\/", "/")
str = Replace$(str, "\b", vbBack)
str = Replace$(str, "\f", vbFormFeed)
str = Replace$(str, "\n", vbCrLf)
str = Replace$(str, "\r", vbCr)
str = Replace$(str, "\t", vbTab)
With regexp
.Global = True
.IgnoreCase = False
.MultiLine = False
.Pattern = "\\u([0-9a-fA-F]{4})"
For Each match In .Execute(str)
str = Replace$(str, match.value, ChrW$(Val("&H" + match.SubMatches(0))), match.FirstIndex + 1, 1)
Next match
End With
Unescape = str
End Function
Private Function ParseStep(ByVal str As String, _
ByRef index As Long, _
ByRef value As Variant, _
ByVal json_step As JsonStep, _
ByVal expected As Boolean) As Boolean
Dim match As Object
With regexp
.Global = False
.IgnoreCase = False
.MultiLine = False
Select Case json_step
'Case jsonString: .Pattern = "^\s*""(([^\\""]+|\\[""\\/bfnrt]|\\u[0-9a-fA-F]{4})*)""\s*"
Case jsonString: .Pattern = "^\s*""([^\\""]+|([^\\""]+|\\[""\\/bfnrt]|\\u[0-9a-fA-F]{4})*)""\s*"
Case jsonNumber: .Pattern = "^\s*(-?(0|[1-9]\d*)(\.\d+)?([eE][-+]?\d+)?)\s*"
Case jsonTrue: .Pattern = "^\s*(true)\s*"
Case jsonFalse: .Pattern = "^\s*(false)\s*"
Case jsonNull: .Pattern = "^\s*(null)\s*"
Case jsonOpeningBrace: .Pattern = "^\s*(\{)\s*"
Case jsonClosingBrace: .Pattern = "^\s*(\})\s*"
Case jsonOpeningBracket: .Pattern = "^\s*(\[)\s*"
Case jsonClosingBracket: .Pattern = "^\s*(\])\s*"
Case jsonComma: .Pattern = "^\s*(\,)\s*"
Case jsonColon: .Pattern = "^\s*(:)\s*"
End Select
Set match = .Execute(Mid$(str, index))
End With
If match.Count > 0 Then
index = index + match(0).Length
Select Case json_step
Case jsonString
If match(0).SubMatches(1) = Empty Then
value = match(0).SubMatches(0)
Else
value = Unescape(match(0).SubMatches(0))
End If
Case jsonNumber: value = Val(match(0).SubMatches(0))
Case jsonTrue: value = True
Case jsonFalse: value = False
Case jsonNull: value = Null
Case Else: value = Empty
End Select
ParseStep = True
ElseIf expected Then
Err.Raise 10001, "ParseJson", "Expecting " & JsonStepName(json_step) & " at char " & index & "."
End If
End Function
Private Function ParseValue(ByRef str As String, _
ByRef index As Long, _
ByRef value As Variant, _
ByVal expected As Boolean) As Boolean
ParseValue = True
If ParseStep(str, index, value, jsonString, False) Then Exit Function
If ParseStep(str, index, value, jsonNumber, False) Then Exit Function
If ParseObject(str, index, value, False) Then Exit Function
If ParseArray(str, index, value, False) Then Exit Function
If ParseStep(str, index, value, jsonTrue, False) Then Exit Function
If ParseStep(str, index, value, jsonFalse, False) Then Exit Function
If ParseStep(str, index, value, jsonNull, False) Then Exit Function
ParseValue = False
If expected Then
Err.Raise 10001, "ParseJson", "Expecting " & JsonStepName(jsonString) & ", " & JsonStepName(jsonNumber) & ", " & JsonStepName(jsonTrue) & ", " & JsonStepName(jsonFalse) & ", " & JsonStepName(jsonNull) & ", " & JsonStepName(jsonOpeningBrace) & ", or " & JsonStepName(jsonOpeningBracket) & " at char " & index & "."
End If
End Function
Private Function ParseObject(ByRef str As String, _
ByRef index As Long, _
ByRef obj As Variant, _
ByVal expected As Boolean) As Boolean
Dim key As Variant
Dim value As Variant
ParseObject = ParseStep(str, index, Empty, jsonOpeningBrace, expected)
If ParseObject Then
Set obj = CreateObject("Scripting.Dictionary")
If ParseStep(str, index, Empty, jsonClosingBrace, False) Then Exit Function
Do
If ParseStep(str, index, key, jsonString, True) Then
If ParseStep(str, index, Empty, jsonColon, True) Then
If ParseValue(str, index, value, True) Then
If IsObject(value) Then
Set obj.Item(key) = value
Else
obj.Item(key) = value
End If
End If
End If
End If
Loop While ParseStep(str, index, Empty, jsonComma, False)
ParseObject = ParseStep(str, index, Empty, jsonClosingBrace, True)
End If
End Function
Private Function ParseArray(ByRef str As String, _
ByRef index As Long, _
ByRef arr As Variant, _
ByVal expected As Boolean) As Boolean
Dim key As Variant
Dim value As Variant
ParseArray = ParseStep(str, index, Empty, jsonOpeningBracket, expected)
If ParseArray Then
Set arr = New Collection
If ParseStep(str, index, Empty, jsonClosingBracket, False) Then Exit Function
Do
If ParseValue(str, index, value, True) Then
arr.Add value
End If
Loop While ParseStep(str, index, Empty, jsonComma, False)
ParseArray = ParseStep(str, index, Empty, jsonClosingBracket, True)
End If
End Function
Public Function ParseJson(ByVal str As String) As Object
If regexp Is Nothing Then
Set regexp = CreateObject("VBScript.RegExp")
End If
If ParseObject(str, 1, ParseJson, False) Then Exit Function
If ParseArray(str, 1, ParseJson, False) Then Exit Function
Err.Raise 10001, "ParseJson", "Expecting " & JsonStepName(jsonOpeningBrace) & " or " & JsonStepName(jsonOpeningBracket) & "."
End Function
对Codo的回答有两个小贡献：
' "recursive" version of GetObjectProperty
Public Function GetObjectProperty(ByVal JsonObject As Object, ByVal propertyName As String) As Object
Dim names() As String
Dim i As Integer
names = Split(propertyName, ".")
For i = 0 To UBound(names)
Set JsonObject = ScriptEngine.Run("getProperty", JsonObject, names(i))
Next
Set GetObjectProperty = JsonObject
End Function
' shortcut to object array
Public Function GetObjectArrayProperty(ByVal JsonObject As Object, ByVal propertyName As String) As Object()
Dim a() As Object
Dim i As Integer
Dim l As Integer
Set JsonObject = GetObjectProperty(JsonObject, propertyName)
l = GetProperty(JsonObject, "length") - 1
ReDim a(l)
For i = 0 To l
Set a(i) = GetObjectProperty(JsonObject, CStr(i))
Next
GetObjectArrayProperty = a
End Function
所以现在我可以做类似的事情：
Dim JsonObject As Object
Dim Value() As Object
Dim i As Integer
Dim Total As Double
Set JsonObject = DecodeJsonString(CStr(request.responseText))
Value = GetObjectArrayProperty(JsonObject, "d.Data")
For i = 0 To UBound(Value)
Total = Total + Value(i).Amount
Next
这里有很多好的答案-只是我自己一个人。
我需要解析一个非常特定的JSON字符串，该字符串代表进行Web-API调用的结果。JSON描述了一个对象列表，看起来像这样：
[
{
"property1": "foo",
"property2": "bar",
"timeOfDay": "2019-09-30T00:00:00",
"numberOfHits": 98,
"isSpecial": false,
"comment": "just to be awkward, this contains a comma"
},
{
"property1": "fool",
"property2": "barrel",
"timeOfDay": "2019-10-31T00:00:00",
"numberOfHits": 11,
"isSpecial": false,
"comment": null
},
...
]
关于此，需要注意以下几点：
null）。ParseListOfObjects以下代码中的函数将JSON字符串作为输入，并返回Collection代表列表中项目的。每个项目都以表示Dictionary，其中字典的键对应于对象属性的名称。的值被自动转换为适当的类型（String，Date，Double，Boolean-或者Empty如果该值null）。
您的VBA项目将需要对Microsoft Scripting Runtime库的引用才能使用该Dictionary对象-尽管如果您使用不同的编码结果的方式来删除此依赖关系也不会很困难。
这是我的JSON.bas：
Option Explicit
' NOTE: a fully-featured JSON parser in VBA would be a beast.
' This simple parser only supports VERY simple JSON (which is all we need).
' Specifically, it supports JSON comprising a list of objects, each of which has only simple properties.
Private Const strSTART_OF_LIST As String = "["
Private Const strEND_OF_LIST As String = "]"
Private Const strLIST_DELIMITER As String = ","
Private Const strSTART_OF_OBJECT As String = "{"
Private Const strEND_OF_OBJECT As String = "}"
Private Const strOBJECT_PROPERTY_NAME_VALUE_SEPARATOR As String = ":"
Private Const strQUOTE As String = """"
Private Const strNULL_VALUE As String = "null"
Private Const strTRUE_VALUE As String = "true"
Private Const strFALSE_VALUE As String = "false"
Public Function ParseListOfObjects(ByVal strJson As String) As Collection
' Takes a JSON string that represents a list of objects (where each object has only simple value properties), and
' returns a collection of dictionary objects, where the keys and values of each dictionary represent the names and
' values of the JSON object properties.
Set ParseListOfObjects = New Collection
Dim strList As String: strList = Trim(strJson)
' Check we have a list
If Left(strList, Len(strSTART_OF_LIST)) <> strSTART_OF_LIST _
Or Right(strList, Len(strEND_OF_LIST)) <> strEND_OF_LIST Then
Err.Raise vbObjectError, Description:="The provided JSON does not appear to be a list (it does not start with '" & strSTART_OF_LIST & "' and end with '" & strEND_OF_LIST & "')"
End If
' Get the list item text (between the [ and ])
Dim strBody As String: strBody = Trim(Mid(strList, 1 + Len(strSTART_OF_LIST), Len(strList) - Len(strSTART_OF_LIST) - Len(strEND_OF_LIST)))
If strBody = "" Then
Exit Function
End If
' Check we have a list of objects
If Left(strBody, Len(strSTART_OF_OBJECT)) <> strSTART_OF_OBJECT Then
Err.Raise vbObjectError, Description:="The provided JSON does not appear to be a list of objects (the content of the list does not start with '" & strSTART_OF_OBJECT & "')"
End If
' We now have something like:
' {"property":"value", "property":"value"}, {"property":"value", "property":"value"}, ...
' so we can't just split on a comma to get the various items (because the items themselves have commas in them).
' HOWEVER, since we know we're dealing with very simple JSON that has no nested objects, we can split on "}," because
' that should only appear between items. That'll mean that all but the last item will be missing it's closing brace.
Dim astrItems() As String: astrItems = Split(strBody, strEND_OF_OBJECT & strLIST_DELIMITER)
Dim ixItem As Long
For ixItem = LBound(astrItems) To UBound(astrItems)
Dim strItem As String: strItem = Trim(astrItems(ixItem))
If Left(strItem, Len(strSTART_OF_OBJECT)) <> strSTART_OF_OBJECT Then
Err.Raise vbObjectError, Description:="Mal-formed list item (does not start with '" & strSTART_OF_OBJECT & "')"
End If
' Only the last item will have a closing brace (see comment above)
Dim bIsLastItem As Boolean: bIsLastItem = ixItem = UBound(astrItems)
If bIsLastItem Then
If Right(strItem, Len(strEND_OF_OBJECT)) <> strEND_OF_OBJECT Then
Err.Raise vbObjectError, Description:="Mal-formed list item (does not end with '" & strEND_OF_OBJECT & "')"
End If
End If
Dim strContent: strContent = Mid(strItem, 1 + Len(strSTART_OF_OBJECT), Len(strItem) - Len(strSTART_OF_OBJECT) - IIf(bIsLastItem, Len(strEND_OF_OBJECT), 0))
ParseListOfObjects.Add ParseObjectContent(strContent)
Next ixItem
End Function
Private Function ParseObjectContent(ByVal strContent As String) As Scripting.Dictionary
Set ParseObjectContent = New Scripting.Dictionary
ParseObjectContent.CompareMode = TextCompare
' The object content will look something like:
' "property":"value", "property":"value", ...
' ... although the value may not be in quotes, since numbers are not quoted.
' We can't assume that the property value won't contain a comma, so we can't just split the
' string on the commas, but it's reasonably safe to assume that the value won't contain further quotes
' (and we're already assuming no sub-structure).
' We'll need to scan for commas while taking quoted strings into account.
Dim ixPos As Long: ixPos = 1
Do While ixPos <= Len(strContent)
Dim strRemainder As String
' Find the opening quote for the name (names should always be quoted)
Dim ixOpeningQuote As Long: ixOpeningQuote = InStr(ixPos, strContent, strQUOTE)
If ixOpeningQuote <= 0 Then
' The only valid reason for not finding a quote is if we're at the end (though white space is permitted)
strRemainder = Trim(Mid(strContent, ixPos))
If Len(strRemainder) = 0 Then
Exit Do
End If
Err.Raise vbObjectError, Description:="Mal-formed object (the object name does not start with a quote)"
End If
' Now find the closing quote for the name, which we assume is the very next quote
Dim ixClosingQuote As Long: ixClosingQuote = InStr(ixOpeningQuote + 1, strContent, strQUOTE)
If ixClosingQuote <= 0 Then
Err.Raise vbObjectError, Description:="Mal-formed object (the object name does not end with a quote)"
End If
If ixClosingQuote - ixOpeningQuote - Len(strQUOTE) = 0 Then
Err.Raise vbObjectError, Description:="Mal-formed object (the object name is blank)"
End If
Dim strName: strName = Mid(strContent, ixOpeningQuote + Len(strQUOTE), ixClosingQuote - ixOpeningQuote - Len(strQUOTE))
' The next thing after the quote should be the colon
Dim ixNameValueSeparator As Long: ixNameValueSeparator = InStr(ixClosingQuote + Len(strQUOTE), strContent, strOBJECT_PROPERTY_NAME_VALUE_SEPARATOR)
If ixNameValueSeparator <= 0 Then
Err.Raise vbObjectError, Description:="Mal-formed object (missing '" & strOBJECT_PROPERTY_NAME_VALUE_SEPARATOR & "')"
End If
' Check that there was nothing between the closing quote and the colon
strRemainder = Trim(Mid(strContent, ixClosingQuote + Len(strQUOTE), ixNameValueSeparator - ixClosingQuote - Len(strQUOTE)))
If Len(strRemainder) > 0 Then
Err.Raise vbObjectError, Description:="Mal-formed object (unexpected content between name and '" & strOBJECT_PROPERTY_NAME_VALUE_SEPARATOR & "')"
End If
' What comes after the colon is the value, which may or may not be quoted (e.g. numbers are not quoted).
' If the very next thing we see is a quote, then it's a quoted value, and we need to find the matching
' closing quote while ignoring any commas inside the quoted value.
' If the next thing we see is NOT a quote, then it must be an unquoted value, and we can scan directly
' for the next comma.
' Either way, we're looking for a quote or a comma, whichever comes first (or neither, in which case we
' have the last - unquoted - value).
ixOpeningQuote = InStr(ixNameValueSeparator + Len(strOBJECT_PROPERTY_NAME_VALUE_SEPARATOR), strContent, strQUOTE)
Dim ixPropertySeparator As Long: ixPropertySeparator = InStr(ixNameValueSeparator + Len(strOBJECT_PROPERTY_NAME_VALUE_SEPARATOR), strContent, strLIST_DELIMITER)
If ixOpeningQuote > 0 And ixPropertySeparator > 0 Then
' Only use whichever came first
If ixOpeningQuote < ixPropertySeparator Then
ixPropertySeparator = 0
Else
ixOpeningQuote = 0
End If
End If
Dim strValue As String
Dim vValue As Variant
If ixOpeningQuote <= 0 Then ' it's not a quoted value
If ixPropertySeparator <= 0 Then ' there's no next value; this is the last one
strValue = Trim(Mid(strContent, ixNameValueSeparator + Len(strOBJECT_PROPERTY_NAME_VALUE_SEPARATOR)))
ixPos = Len(strContent) + 1
Else ' this is not the last value
strValue = Trim(Mid(strContent, ixNameValueSeparator + Len(strOBJECT_PROPERTY_NAME_VALUE_SEPARATOR), ixPropertySeparator - ixNameValueSeparator - Len(strOBJECT_PROPERTY_NAME_VALUE_SEPARATOR)))
ixPos = ixPropertySeparator + Len(strLIST_DELIMITER)
End If
vValue = ParseUnquotedValue(strValue)
Else ' It is a quoted value
' Find the corresponding closing quote, which should be the very next one
ixClosingQuote = InStr(ixOpeningQuote + Len(strQUOTE), strContent, strQUOTE)
If ixClosingQuote <= 0 Then
Err.Raise vbObjectError, Description:="Mal-formed object (the value does not end with a quote)"
End If
strValue = Mid(strContent, ixOpeningQuote + Len(strQUOTE), ixClosingQuote - ixOpeningQuote - Len(strQUOTE))
vValue = ParseQuotedValue(strValue)
' Re-scan for the property separator, in case we hit one that was part of the quoted value
ixPropertySeparator = InStr(ixClosingQuote + Len(strQUOTE), strContent, strLIST_DELIMITER)
If ixPropertySeparator <= 0 Then ' this was the last value
' Check that there's nothing between the closing quote and the end of the text
strRemainder = Trim(Mid(strContent, ixClosingQuote + Len(strQUOTE)))
If Len(strRemainder) > 0 Then
Err.Raise vbObjectError, Description:="Mal-formed object (there is content after the last value)"
End If
ixPos = Len(strContent) + 1
Else ' this is not the last value
' Check that there's nothing between the closing quote and the property separator
strRemainder = Trim(Mid(strContent, ixClosingQuote + Len(strQUOTE), ixPropertySeparator - ixClosingQuote - Len(strQUOTE)))
If Len(strRemainder) > 0 Then
Err.Raise vbObjectError, Description:="Mal-formed object (there is content after the last value)"
End If
ixPos = ixPropertySeparator + Len(strLIST_DELIMITER)
End If
End If
ParseObjectContent.Add strName, vValue
Loop
End Function
Private Function ParseUnquotedValue(ByVal strValue As String) As Variant
If StrComp(strValue, strNULL_VALUE, vbTextCompare) = 0 Then
ParseUnquotedValue = Empty
ElseIf StrComp(strValue, strTRUE_VALUE, vbTextCompare) = 0 Then
ParseUnquotedValue = True
ElseIf StrComp(strValue, strFALSE_VALUE, vbTextCompare) = 0 Then
ParseUnquotedValue = False
ElseIf IsNumeric(strValue) Then
ParseUnquotedValue = CDbl(strValue)
Else
Err.Raise vbObjectError, Description:="Mal-formed value (not null, true, false or a number)"
End If
End Function
Private Function ParseQuotedValue(ByVal strValue As String) As Variant
' Both dates and strings are quoted; we'll treat it as a date if it has the expected date format.
' Dates are in the form:
' 2019-09-30T00:00:00
If strValue Like "####-##-##T##:00:00" Then
' NOTE: we just want the date part
ParseQuotedValue = CDate(Left(strValue, Len("####-##-##")))
Else
ParseQuotedValue = strValue
End If
End Function
一个简单的测试：
Const strJSON As String = "[{""property1"":""foo""}]"
Dim oObjects As Collection: Set oObjects = Json.ParseListOfObjects(strJSON)
MsgBox oObjects(1)("property1") ' shows "foo"