Parsing JSON in Excel VBA

Ho lo stesso problema di Excel VBA: Parsed JSON Object Loop ma non riesco a trovare alcuna soluzione. Il mio JSON ha oggetti nidificati quindi le soluzioni suggerite come VBJSON e vbajson non funzionano per me. Ho anche corretto uno di essi per funzionare correttamente, ma il risultato è stato un overflow dello stack di chiamate a causa di molte ricorsioni della funzione doProcess.

La soluzione migliore sembra essere la funzione jsonDecode vista nel post originale. È molto veloce e molto efficacemente efficace; la mia struttura a oggetti è tutto lì in un object VBA generico di tipo JScriptTypeInfo.

Il problema a questo punto è che non riesco a determinare quale sarà la struttura degli oggetti, quindi, non conosco in anticipo le chiavi che risiederanno in ogni object generico. Ho bisogno di scorrere l’object VBA generico per acquisire le chiavi / proprietà.

Se la mia funzione javascript di analisi potesse triggersre una funzione VBA o sub, sarebbe eccellente.

Se vuoi build su ScriptControl , puoi aggiungere qualche metodo di supporto per ottenere le informazioni richieste. L’object JScriptTypeInfo è un po ‘sfortunato: contiene tutte le informazioni rilevanti (come puoi vedere nella finestra di Watch ) ma sembra imansible raggiungerlo con VBA. Tuttavia, il motore Javascript può aiutarci:

 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 

Alcune note:

  • Se l’istanza di JScriptTypeInfo fa riferimento a un object Javascript, For Each ... Next non funzionerà. Tuttavia, funziona se si riferisce a un array Javascript (vedere la funzione GetKeys ).
  • Le proprietà di accesso il cui nome è noto solo in fase di esecuzione, utilizzano le funzioni GetProperty e GetObjectProperty .
  • L’array Javascript fornisce le proprietà length , 0 , Item 0 , 1 , Item 1 ecc. Con la notazione dot VBA ( jsonObject.property ), solo la proprietà length è accessibile e solo se si dichiara una variabile chiamata length con tutte le lettere minuscole. Altrimenti il ​​caso non corrisponde e non lo troverà. Le altre proprietà non sono valide in VBA. Quindi meglio usare la funzione GetProperty .
  • Il codice utilizza l’associazione anticipata. Quindi devi aggiungere un riferimento a “Microsoft Script Control 1.0”.
  • È necessario chiamare InitScriptEngine una volta prima di utilizzare le altre funzioni per eseguire InitScriptEngine base.

Ecco un altro metodo per analizzare JSON in VBA, basato su ScriptControl ActiveX, senza librerie esterne:

 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 

AGGIORNARE

Si noti che l'approccio di cui sopra rende il sistema vulnerabile in alcuni casi, dal momento che consente l'accesso diretto alle unità (e altre cose) per il codice JS dannoso tramite ActiveX. Supponiamo che tu stia analizzando la risposta del server web JSON, come JsonString = "{a:(function(){(new ActiveXObject('Scripting.FileSystemObject')).CreateTextFile('C:\\Test.txt')})()}" . Dopo averlo valutato, troverai il nuovo file C:\Test.txt . Quindi l'analisi di JSON con ScriptControl ActiveX non è una buona idea.

Cercando di evitarlo, ho creato un parser JSON basato su RegEx. Gli oggetti {} sono rappresentati da dizionari, che rendono ansible l'uso delle proprietà e dei metodi del dizionario: .Count , .Exists() , .Item() , .Items , .Keys . Le matrici [] sono le tradizionali matrici VB basate su zero, quindi UBound() mostra il numero di elementi. Ecco il codice con alcuni esempi di utilizzo:

 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 

Controllare VBA-JSON-parser su GitHub per l'ultima versione (importare il modulo JSON.bas nel progetto VBA per l'elaborazione JSON).

Un'ulteriore opportunità di questo parser JSON RegEx è che funziona su Office a 64 bit, in cui ScriptControl non è disponibile.

UPDATE2

Tuttavia, se si desidera analizzare JSON su Office 64-bit con ScriptControl , questa risposta può aiutare a farlo funzionare.

In modo più semplice puoi andare array.myitem (0) nel codice VB

la mia risposta completa qui parsing e stringify (serialize)

Usa l’object “this” in js

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

Quindi puoi andare 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 

Come Json non è altro che stringhe quindi può essere facilmente gestito se possiamo manipolarlo nel modo giusto, non importa quanto sia complessa la struttura. Non penso sia necessario utilizzare alcuna libreria o convertitore esterno per fare il trucco. Ecco un esempio in cui ho analizzato i dati JSON usando la manipolazione delle stringhe.

 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 

Grazie mille Codo.

Ho appena aggiornato e completato ciò che hai fatto:

  • serializzare il json (ne ho bisogno per iniettare il json in un documento simile a un testo)
  • aggiungi, rimuovi e aggiorna il nodo (chi lo sa)

     Option Explicit Private ScriptEngine As ScriptControl Public Sub InitScriptEngine() Set ScriptEngine = New ScriptControl ScriptEngine.Language = "JScript" ScriptEngine.AddCode "function getProperty(jsonObj, propertyName) { return jsonObj[propertyName]; } " ScriptEngine.AddCode "function getType(jsonObj, propertyName) {return typeof(jsonObj[propertyName]);}" ScriptEngine.AddCode "function getKeys(jsonObj) { var keys = new Array(); for (var i in jsonObj) { keys.push(i); } return keys; } " ScriptEngine.AddCode "function addKey(jsonObj, propertyName, value) { jsonObj[propertyName] = value; return jsonObj;}" ScriptEngine.AddCode "function removeKey(jsonObj, propertyName) { var json = jsonObj; delete json[propertyName]; return json }" End Sub Public Function removeJSONProperty(ByVal JsonObject As Object, propertyName As String) Set removeJSONProperty = ScriptEngine.Run("removeKey", JsonObject, propertyName) End Function Public Function updateJSONPropertyValue(ByVal JsonObject As Object, propertyName As String, value As String) As Object Set updateJSONPropertyValue = ScriptEngine.Run("removeKey", JsonObject, propertyName) Set updateJSONPropertyValue = ScriptEngine.Run("addKey", JsonObject, propertyName, value) End Function Public Function addJSONPropertyValue(ByVal JsonObject As Object, propertyName As String, value As String) As Object Set addJSONPropertyValue = ScriptEngine.Run("addKey", JsonObject, propertyName, value) End Function Public Function DecodeJsonString(ByVal JsonString As String) InitScriptEngine Set DecodeJsonString = ScriptEngine.Eval("(" + JsonString + ")") End Function Public Function GetProperty(ByVal JsonObject As Object, ByVal propertyName As String) As Variant GetProperty = ScriptEngine.Run("getProperty", JsonObject, propertyName) End Function Public Function GetObjectProperty(ByVal JsonObject As Object, ByVal propertyName As String) As Object Set GetObjectProperty = ScriptEngine.Run("getProperty", JsonObject, propertyName) End Function Public Function SerializeJSONObject(ByVal JsonObject As Object) As String() Dim Length As Integer Dim KeysArray() As String Dim KeysObject As Object Dim Index As Integer Dim Key As Variant Dim tmpString As String Dim tmpJSON As Object Dim tmpJSONArray() As Variant Dim tmpJSONObject() As Variant Dim strJsonObject As String Dim tmpNbElement As Long, i As Long InitScriptEngine Set KeysObject = ScriptEngine.Run("getKeys", JsonObject) Length = GetProperty(KeysObject, "length") ReDim KeysArray(Length - 1) Index = 0 For Each Key In KeysObject tmpString = "" If ScriptEngine.Run("getType", JsonObject, Key) = "object" Then 'MsgBox "object " & SerializeJSONObject(GetObjectProperty(JsonObject, Key))(0) Set tmpJSON = GetObjectProperty(JsonObject, Key) strJsonObject = VBA.Replace(ScriptEngine.Run("getKeys", tmpJSON), " ", "") tmpNbElement = Len(strJsonObject) - Len(VBA.Replace(strJsonObject, ",", "")) If VBA.IsNumeric(Left(ScriptEngine.Run("getKeys", tmpJSON), 1)) = True Then ReDim tmpJSONArray(tmpNbElement) For i = 0 To tmpNbElement tmpJSONArray(i) = GetProperty(tmpJSON, i) Next tmpString = "[" & Join(tmpJSONArray, ",") & "]" Else tmpString = "{" & Join(SerializeJSONObject(tmpJSON), ", ") & "}" End If Else tmpString = GetProperty(JsonObject, Key) End If KeysArray(Index) = Key & ": " & tmpString Index = Index + 1 Next SerializeJSONObject = KeysArray End Function Public Function GetKeys(ByVal JsonObject As Object) As String() Dim Length As Integer Dim KeysArray() As String Dim KeysObject As Object Dim Index As Integer Dim Key As Variant InitScriptEngine Set KeysObject = ScriptEngine.Run("getKeys", JsonObject) Length = GetProperty(KeysObject, "length") ReDim KeysArray(Length - 1) Index = 0 For Each Key In KeysObject KeysArray(Index) = Key Index = Index + 1 Next GetKeys = KeysArray End Function 

Microsoft : Poiché VBScript è un sottoinsieme di Visual Basic, Applications Edition, …

Il codice sotto è derivato dal post di Codo, dovrebbe anche essere utile avere in forma di class, e utilizzabile come 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 

Uso:

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

Un altro parser JSON basato su Regex (solo decodifica)

 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 

Due piccoli contributi alla risposta di Codo :

 ' "recursive" version of GetObjectProperty Public Function GetObjectProperty(ByVal JsonObject As Object, ByVal propertyName As String) As Object Dim names() As String Dim i As Integer names = Split(propertyName, ".") For i = 0 To UBound(names) Set JsonObject = ScriptEngine.Run("getProperty", JsonObject, names(i)) Next Set GetObjectProperty = JsonObject End Function ' shortcut to object array Public Function GetObjectArrayProperty(ByVal JsonObject As Object, ByVal propertyName As String) As Object() Dim a() As Object Dim i As Integer Dim l As Integer Set JsonObject = GetObjectProperty(JsonObject, propertyName) l = GetProperty(JsonObject, "length") - 1 ReDim a(l) For i = 0 To l Set a(i) = GetObjectProperty(JsonObject, CStr(i)) Next GetObjectArrayProperty = a End Function 

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 

This works for me under Excel and a big JSON files using JSON query translated in to native form. https://github.com/VBA-tools/VBA-JSON I am able parse node like “item.something” and get value using simple command:

 MsgBox Json("item")("something") 

What’s nice.