最好的解决方案似乎是原始帖子中看到的jsonDecode函数。它非常快速和高效；我的对象结构都在一个通用的VBA对象（类型为JScriptTypeInfo）中。
这时问题是我无法确定对象的结构，因此我无法预先知道每个通用对象中将存在哪些键。我需要循环遍历通用VBA对象以获取键/属性。
如果我的解析JavaScript函数能够触发VBA函数或子程序，那将是非常棒的。
ScriptControl的基础上构建，请添加一些辅助方法以获取所需信息。 JScriptTypeInfo对象有点不幸：它包含所有相关信息（如您可以在Watch窗口中看到的那样），但似乎无法使用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的变量并且所有字母都是小写时才能访问。否则，大小写不匹配，无法找到它。其他属性在VBA中无效。因此最好使用GetProperty函数。InitScriptEngine进行一些基本初始化。JsonString = "{a:(function(){(new ActiveXObject('Scripting.FileSystemObject')).CreateTextFile('C:\\Test.txt')})()}"。在评估后，您将找到新创建的文件C：\ Test.txt。因此，使用ScriptControl ActiveX进行JSON解析不是一个好主意。请查看我的答案更新以获取基于RegEx的JSON解析器。 - omegastripesSet se = CreateObject("MSScriptControl.ScriptControl")。+1 谢谢！ - bvjScriptControl解析JSON，那么这个答案可能会帮助您使ScriptControl在64位系统上工作。
更新（2015年10月26日）：请注意，基于ScriptControl的方法在某些情况下会使系统易受攻击，因为它们允许恶意JS代码通过ActiveX直接访问驱动器（等其他内容）。假设您正在解析Web服务器响应JSON，例如JsonString = "{a:(function(){(new ActiveXObject('Scripting.FileSystemObject')).CreateTextFile('C:\\Test.txt')})()}"。评估后，您将发现新创建的文件C:\Test.txt。因此，使用ScriptControl ActiveX解析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正则表达式解析器的另一个优点是它可以在64位Office中使用，而ScriptControl不可用。
初始版本（2015年5月27日）
这里提供了另一种在VBA中解析JSON的方法，基于ScriptControl ActiveX，无需外部库：
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()中被赋值，并作为解析结果返回。 - omegastripes由于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)，当只需要单个结果时，可以提高性能。 - omegastripes为了在不向工作簿项目中添加庞大库的情况下解析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
在VB代码中，您可以更简单地使用数组。例如：array.myitem(0)
在js中可以使用'this'对象
ScriptEngine.AddCode "Object.prototype.myitem=function( i ) { return this[i] } ; "
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
我在Excel中使用JSON查询转换为本地格式，成功地处理了大型JSON文件。这个https://github.com/VBA-tools/VBA-JSON工具非常有用。我可以使用简单的命令解析节点，如"item.something"，并获取其值。
MsgBox Json("item")("something")
有什么好处。
Microsoft: 因为 VBScript 是 Visual Basic for Applications 的子集，...
下面的代码是根据 Codo 的帖子修改而来，如果以类形式呈现并可用于VBScript：
class JsonParser
' adapted from: https://dev59.com/3Ww15IYBdhLWcg3wbLDU
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")
JSON.parse比eval更可靠，而且现在应该是可用的（IE8+）。
Dim jsonString
jsonString = "{""SomeArray"":[{""Val"": 42}]}"
Dim htmlfile
Dim json
Set htmlfile = CreateObject("htmlfile")
Set json = htmlfile.ParentWindow.json
' parse
Dim obj
Set obj = CallByName(json, "parse", VbMethod, jsonString)
' manipulation
' You still need to deal with getProperty stuff...
CallByName(obj.SomeArray, 0, VbGet).Val = "foo"
' stringify
Dim str
str = CallByName(json, "stringify", VbMethod, obj)
Debug.Print str
另一种基于正则表达式的JSON解析器（仅解码）
Option Explicit
Private Enum JsonStep
jstUnexpected
jstString
jstNumber
jstTrue
jstFalse
jstNull
jstOpeningBrace
jstClosingBrace
jstOpeningBracket
jstClosingBracket
jstComma
jstColon
jstWhitespace
End Enum
Private gobjRegExpJsonStep As Object
Private gobjRegExpUnicodeCharacters As Object
Private gobjTokens As Object
Private k As Long
Private Function JsonStepName(ByRef jstStep As JsonStep) As String
Select Case jstStep
Case jstString: JsonStepName = "'STRING'"
Case jstNumber: JsonStepName = "'NUMBER'"
Case jstTrue: JsonStepName = "true"
Case jstFalse: JsonStepName = "false"
Case jstNull: JsonStepName = "null"
Case jstOpeningBrace: JsonStepName = "'{'"
Case jstClosingBrace: JsonStepName = "'}'"
Case jstOpeningBracket: JsonStepName = "'['"
Case jstClosingBracket: JsonStepName = "']'"
Case jstComma: JsonStepName = "','"
Case jstColon: JsonStepName = "':'"
Case jstWhitespace: JsonStepName = "'WHITESPACE'"
Case Else: JsonStepName = "'UNEXPECTED'"
End Select
End Function
Private Function Unescape(ByVal strText As String) As String
Dim objMatches As Object
Dim i As Long
strText = Replace$(strText, "\""", """")
strText = Replace$(strText, "\\", "\")
strText = Replace$(strText, "\/", "/")
strText = Replace$(strText, "\b", vbBack)
strText = Replace$(strText, "\f", vbFormFeed)
strText = Replace$(strText, "\n", vbCrLf)
strText = Replace$(strText, "\r", vbCr)
strText = Replace$(strText, "\t", vbTab)
If gobjRegExpUnicodeCharacters Is Nothing Then
Set gobjRegExpUnicodeCharacters = CreateObject("VBScript.RegExp")
With gobjRegExpUnicodeCharacters
.Global = True
.Pattern = "\\u([0-9a-fA-F]{4})"
End With
End If
Set objMatches = gobjRegExpUnicodeCharacters.Execute(strText)
For i = 0 To objMatches.Count - 1
With objMatches(i)
strText = Replace$(strText, .Value, ChrW$(Val("&H" + .SubMatches(0))), , 1)
End With
Next i
Unescape = strText
End Function
Private Sub Tokenize(ByRef strText As String)
If gobjRegExpJsonStep Is Nothing Then
Set gobjRegExpJsonStep = CreateObject("VBScript.RegExp")
With gobjRegExpJsonStep
.Pattern = "(""((?:[^\\""]+|\\[""\\/bfnrt]|\\u[0-9a-fA-F]{4})*)""|" & _
"(-?(?:0|[1-9]\d*)(?:\.\d+)?(?:[eE][-+]?\d+)?)|" & _
"(true)|" & _
"(false)|" & _
"(null)|" & _
"(\{)|" & _
"(\})|" & _
"(\[)|" & _
"(\])|" & _
"(\,)|" & _
"(:)|" & _
"(\s+)|" & _
"(.+?))"
.Global = True
End With
End If
Set gobjTokens = gobjRegExpJsonStep.Execute(strText)
End Sub
Private Function ErrorMessage(ByRef vntExpecting As Variant) As String
Dim lngLB As Long
Dim lngUB As Long
Dim i As Long
Dim jstJsonStep As JsonStep
Dim strResult As String
If Rank(vntExpecting) = 1 Then
lngLB = LBound(vntExpecting)
lngUB = UBound(vntExpecting)
If lngLB <= lngUB Then
strResult = "Expecting "
For i = lngLB To lngUB
jstJsonStep = vntExpecting(i)
If i > lngLB Then
If i < lngUB Then
strResult = strResult & ", "
Else
strResult = strResult & " or "
End If
End If
strResult = strResult & JsonStepName(jstJsonStep)
Next i
End If
End If
If strResult = "" Then
strResult = "Unexpected error"
End If
If gobjTokens.Count > 0 Then
If k < gobjTokens.Count Then
strResult = strResult & " at position " & (gobjTokens(k).FirstIndex + 1) & "."
Else
strResult = strResult & " at EOF."
End If
Else
strResult = strResult & " at position 1."
End If
ErrorMessage = strResult
End Function
Private Function ParseStep(ByRef vntValue As Variant) As JsonStep
Dim i As Long
k = k + 1
If k >= gobjTokens.Count Then
vntValue = Empty
Exit Function
End If
With gobjTokens(k)
For i = 1 To 12
If Not IsEmpty(.SubMatches(i)) Then
ParseStep = i
Exit For
End If
Next i
Select Case ParseStep
Case jstString
vntValue = Unescape(.SubMatches(1))
Case jstNumber
vntValue = Val(.SubMatches(2))
Case jstTrue
vntValue = True
Case jstFalse
vntValue = False
Case jstNull
vntValue = Null
Case jstWhitespace
ParseStep = ParseStep(vntValue)
Case Else
vntValue = Empty
End Select
End With
End Function
Private Function ParseObject(ByRef vntObject As Variant) As Boolean
Dim strKey As String
Dim vntValue As Variant
Dim objResult As Object
Set objResult = CreateObject("Scripting.Dictionary")
Do
Select Case ParseStep(strKey)
Case jstString
If Not ParseStep(Empty) = jstColon Then
LogError "ParseObject", ErrorMessage(Array(jstColon))
Exit Function
End If
Select Case ParseStep(vntValue)
Case jstString, jstNumber, jstTrue, jstFalse, jstNull
objResult.Item(strKey) = vntValue
Case jstOpeningBrace
If ParseObject(vntValue) Then
Set objResult.Item(strKey) = vntValue
End If
Case jstOpeningBracket
If ParseArray(vntValue) Then
Set objResult.Item(strKey) = vntValue
End If
Case Else
LogError "ParseObject", ErrorMessage(Array(jstString, jstNumber, jstTrue, jstFalse, jstNull, jstOpeningBrace, jstOpeningBracket))
Exit Function
End Select
Select Case ParseStep(Empty)
Case jstComma
'Do nothing
Case jstClosingBrace
Set vntObject = objResult
ParseObject = True
Exit Function
Case Else
LogError "ParseObject", ErrorMessage(Array(jstComma, jstClosingBrace))
Exit Function
End Select
Case jstClosingBrace
Set vntObject = objResult
ParseObject = True
Exit Function
Case Else
LogError "ParseObject", ErrorMessage(Array(jstString, jstClosingBrace))
Exit Function
End Select
Loop While True
End Function
Private Function ParseArray(ByRef vntArray As Variant) As Boolean
Dim vntValue As Variant
Dim colResult As Collection
Set colResult = New Collection
Do
Select Case ParseStep(vntValue)
Case jstString, jstNumber, jstTrue, jstFalse, jstNull
colResult.Add vntValue
Case jstOpeningBrace
If ParseObject(vntArray) Then
colResult.Add vntArray
End If
Case jstOpeningBracket
If ParseArray(vntArray) Then
colResult.Add vntArray
End If
Case jstClosingBracket
Set vntArray = colResult
ParseArray = True
Exit Function
Case Else
LogError "ParseArray", ErrorMessage(Array(jstString, jstNumber, jstTrue, jstFalse, jstNull, jstOpeningBrace, jstOpeningBracket, jstClosingBracket))
Exit Function
End Select
Select Case ParseStep(Empty)
Case jstComma
'Do nothing
Case jstClosingBracket
Set vntArray = colResult
ParseArray = True
Exit Function
Case Else
LogError "ParseArray", ErrorMessage(Array(jstComma, jstClosingBracket))
Exit Function
End Select
Loop While True
End Function
Public Function ParseJson(ByRef strText As String, _
ByRef objJson As Object) As Boolean
Tokenize strText
k = -1
Select Case ParseStep(Empty)
Case jstOpeningBrace
ParseJson = ParseObject(objJson)
Case jstOpeningBracket
ParseJson = ParseArray(objJson)
Case Else
LogError "ParseJson", ErrorMessage(Array(jstOpeningBrace, jstOpeningBracket))
End Select
End Function
添加、删除和更新节点（谁知道呢）
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