在Excel VBA中parsingJSON

我在Excel VBA中有相同的问题：parsingJSON对象循环但找不到任何解决scheme。 我的JSON嵌套对象，所以build议像VBJSON和vba-json解决scheme不适合我。 我也修复其中一个正常工作，但由于许多recursion的doProcess函数，结果是一个调用堆栈溢出。

最好的解决scheme似乎是在原始文章中看到的jsonDecode函数。 这是非常快速和高效的有效; 我的对象结构都在JScriptTypeInfotypes的通用VBA对象中。

现在的问题是，我不能确定什么是对象的结构，因此，我不知道将驻留在每个通用对象中的键。 我需要遍历通用的VBA对象来获取键/属性。

如果我的parsingJavaScript函数可能会触发一个VBA函数或子，这将是非常好的。

Answer 1

如果你想在ScriptControl之上构build，你可以添加一些帮助方法来获得所需的信息。 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 。
• Javascript数组提供的属性length 0 ， Item 0 ， Item 1等。对于VBA点表示法（ jsonObject.property ），只有长度属性是可访问的，并且只有在声明了一个名为length全部为小写字母的variables时才是可访问的。 否则，案件不匹配，它不会find它。 其他属性在VBA中无效。 所以最好使用GetProperty函数。
• 该代码使用早期绑定。 所以你必须添加一个对“Microsoft Script Control 1.0”的引用。
• 在使用其他函数进行一些基本的初始化之前，您必须调用InitScriptEngine一次。

Answer 2

这里有一个方法来parsing基于ScriptControl ActiveX的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 

UPDATE

请注意，上述方法在某些情况下会使系统易受攻击，因为它允许通过ActiveX直接访问恶意JS代码的驱动器（和其他东西）。 假设您正在parsingWeb服务器响应JSON，如JsonString = "{a:(function(){(new ActiveXObject('Scripting.FileSystemObject')).CreateTextFile('C:\\Test.txt')})()}" 。 评估它后，你会发现新的创build文件C:\Test.txt 。 所以JSONparsing与ScriptControl ActiveX不是一个好主意。

试图避免这种情况，我已经创build了基于RegEx的JSONparsing器。 对象{}由字典表示，可以使用字典的属性和方法： .Count ， .Exists() .Item() .Count ， .Exists() 。 数组[]是传统的基于零的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 

检查GitHub上的VBA-JSONparsing器是否为最新版本。

这个JSON正则expression式parsing器的另一个机会是，它可以在64位Office上使用ScriptControl。

UPDATE2

但是，如果您确实想要使用ScriptControl在64位Office上parsingJSON，则此答案可能会帮助您使其工作。

Answer 3

更简单的方法你可以在VB代码中使用array.myitem（0）

我在这里完整的答案parsing和stringify（序列化）

在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 

Answer 4

由于Json只是string，所以无论结构多么复杂，如果我们可以正确地操作它，它就可以很容易地处理。 我不认为有必要使用任何外部库或转换器来伎俩。 这是一个例子，我已经使用string操作parsing了json数据。

 Sub Json_stuff() Dim http As New XMLHTTP60, str As Variant With http .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 x = UBound(str) On Error Resume Next For V = 1 To x Cells(V, 1) = Split(Split(str(V), "FullName"":""")(1), """")(0) Cells(V, 2) = Split(Split(str(V), "Phone"":""")(1), """")(0) Cells(V, 3) = Split(Split(str(V), "Email"":""")(1), """")(0) Next V End Sub 

Answer 5

非常感谢科多。

我刚刚更新并完成了您所做的工作：

• 序列化的JSON（我需要它注入一个文本文件的JSON）

• 添加，删除和更新节点（谁知道）

   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 

Answer 6

Microsoft ：由于VBScript是Visual Basic for Applications的子集，因此…

下面的代码是从Codo的post派生出来的，如果它在类中也是有用的，并且可以用作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") 

Answer 7

另一个基于正则expression式的JSONparsing器（仅解码）

 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 

Answer 8

对科多答案的两个小贡献：

 ' "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