Parsing JSON in Excel VBA

问题:

I have the same issue as in Excel VBA: Parsed JSON Object Loop but cannot find any solution. My JSON has nested objects so suggested solution like VBJSON and vba-json do not work for me. I also fixed one of them to work properly but the result was a call stack overflow because of to many recursion of the doProcess function.

The best solution appears to be the jsonDecode function seen in the original post. It is very fast and highly effectively effective; my object structure is all there in a generic VBA Object of type JScriptTypeInfo.

The issue at this point is that I cannot determine what will be the structure of the objects, therefore, I do not know beforehand the keys that will reside in each generic objects. I need to loop through the generic VBA Object to acquire the keys/properties.

If my parsing javascript function could trigger a VBA function or sub, that would be excellent.

回答1:

If you want to build on top of ScriptControl, you can add a few helper method to get at the required information. The JScriptTypeInfo object is a bit unfortunate: it contains all the relevant information (as you can see in the Watch window) but it seems impossible to get at it with VBA. However, the Javascript engine can help us:

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 

A few notes:

• If the JScriptTypeInfo instance refers to a Javascript object, For Each ... Next won't work. However, it does work if it refers to a Javascript array (see GetKeys function).
• The access properties whose name is only known at run-time, use the functions GetProperty and GetObjectProperty.
• The Javascript array provides the properties length, 0, Item 0, 1, Item 1 etc. With the VBA dot notation (jsonObject.property), only the length property is accessible and only if you declare a variable called length with all lowercase letters. Otherwise the case doesn't match and it won't find it. The other properties are not valid in VBA. So better use the GetProperty function.
• The code uses early binding. So you have to add a reference to "Microsoft Script Control 1.0".
• You have to call InitScriptEngine once before using the other functions to do some basic initialization.

回答2:

Here is one more method to parse JSON in VBA, based on ScriptControl ActiveX, without external libraries:

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 

UPDATE

Note that the above approach makes the system vulnerable in some cases, since it allows the direct access to the drives (and other stuff) for the malicious JS code via ActiveX's. Let's suppose you are parsing web server response JSON, like JsonString = "{a:(function(){(new ActiveXObject('Scripting.FileSystemObject')).CreateTextFile('C:\\Test.txt')})()}". After evaluating it you'll find new created file C:\Test.txt. So JSON parsing with ScriptControl ActiveX is not a good idea.

Trying to avoid that, I've created JSON parser based on RegEx's. Objects {} are represented by dictionaries, that makes possible to use dictionary's properties and methods: .Count, .Exists(), .Item(), .Items, .Keys. Arrays [] are the conventional zero-based VB arrays, so UBound() shows the number of elements. Here is the code with some usage examples:

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 = "\:"             Tokenize objTokens, objRegEx, strContent, bMatched, "prp"             .Pattern = "\{(?:(?:,)*)?\}"             Tokenize objTokens, objRegEx, strContent, bMatched, "obj"             .Pattern = "\[(?:(?:,)*)?\]"             Tokenize objTokens, objRegEx, strContent, bMatched, "arr"         Loop While bMatched         .Pattern = "^$" ' 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 = ""             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 = ""                 Set objMatches = .Execute(strContent)                 Set varTransfer = CreateObject("Scripting.Dictionary")                 For Each objMatch In objMatches                     Retrieve objTokens, objRegEx, objMatch.Value, varTransfer                 Next             Case "prp"                 .Pattern = ""                 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 = ""                 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 

Check VBA-JSON-parser on GitHub for the latest version (import JSON.bas module into the VBA project for JSON processing).

One more opportunity of this JSON RegEx parser is that it works on 64-bit Office, where ScriptControl isn't available.

UPDATE2

However if you do want to parse JSON on 64-bit Office with ScriptControl, then this answer may help you to get it to work.

回答3:

Simpler way you can go array.myitem(0) in VB code

my full answer here parse and stringify (serialize)

Use the 'this' object in js

ScriptEngine.AddCode "Object.prototype.myitem=function( i ) { return this[i] } ; " 

Then you can go 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 

回答4:

As Json is nothing but strings so it can easily be handled if we can manipulate it the right way, no matter how complex the structure is. I don't think it is necessary to use any external library or converter to do the trick. Here is an example where I've parsed json data using string manipulation.

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 

回答5:

Thanks a lot Codo.

I've just updated and completed what you have done to :

• serialize the json (I need it to inject the json in a text-like document)

• add, remove and update node (who knows)

  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 

回答6:

Microsoft: Because VBScript is a subset of Visual Basic for Applications,...

The code below is derived from Codo's post should it also be helpful to have in class form, and usable as 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 

Usage:

set jp = new JsonParser set jo = jp.Decode("{value: true}") keys = jp.EnumKeys(jo) value = jp.GetValue(jo, "value") 

回答7:

Another Regex based JSON parser (decode only)

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 

回答8:

Two small contributions to Codo's answer:

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

So now I can do stuff like:

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 

文章来源: Parsing JSON in Excel VBA