parser parsejson leer importar example datos json excel parsing vba object

leer - parsejson vba excel



Analizando JSON en Excel VBA (9)

Tengo el mismo problema que en Excel VBA: Parsed JSON Object Loop, pero no puedo encontrar ninguna solución. Mi JSON tiene objetos anidados, por lo que la solución sugerida, como VBJSON y vba-json, no me funciona. También solucioné uno de ellos para que funcionara correctamente, pero el resultado fue un desbordamiento de la pila de llamadas debido a la repetición de la función doProcess.

La mejor solución parece ser la función jsonDecode que se ve en la publicación original. Es muy rápido y altamente efectivo; mi estructura de objetos está todo allí en un objeto VBA genérico de tipo JScriptTypeInfo.

El problema en este punto es que no puedo determinar cuál será la estructura de los objetos, por lo tanto, no sé de antemano las claves que residirán en cada objeto genérico. Necesito recorrer el Objeto VBA genérico para adquirir las claves / propiedades.

Si mi función de JavaScript sintáctico pudiera desencadenar una función o sub de VBA, sería excelente.


Microsoft : Porque VBScript es un subconjunto de Visual Basic para Aplicaciones, ...

El siguiente código se deriva de la publicación de Codo si también es útil tenerlo en forma de clase, y se puede usar como VBScript :

class JsonParser '' adapted from: http://.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")


Aquí hay un método más para analizar JSON en VBA, basado en ScriptControl ActiveX, sin bibliotecas externas:

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

ACTUALIZAR

Tenga en cuenta que el enfoque anterior hace que el sistema sea vulnerable en algunos casos, ya que permite el acceso directo a las unidades (y otras cosas) para el código JS malicioso a través de ActiveX. Supongamos que está analizando la respuesta del servidor web JSON, como JsonString = "{a:(function(){(new ActiveXObject(''Scripting.FileSystemObject'')).CreateTextFile(''C://Test.txt'')})()}" . Después de evaluarlo, encontrará un nuevo archivo creado C:/Test.txt . Entonces el análisis JSON con ScriptControl ActiveX no es una buena idea.

Tratando de evitar eso, he creado el analizador JSON basado en RegEx. Los objetos {} están representados por diccionarios, que hacen posible usar las propiedades y métodos del diccionario: .Count , .Exists() , .Item() , .Items , .Keys . Las matrices [] son las matrices VB basadas en cero convencionales, por lo que UBound() muestra la cantidad de elementos. Aquí está el código con algunos ejemplos de uso:

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

Verifique el analizador VBA-JSON en GitHub para la última versión (importe el módulo JSON.bas en el proyecto VBA para el procesamiento JSON).

Una oportunidad más de este analizador JSON RegEx es que funciona en Office de 64 bits, donde ScriptControl no está disponible.

ACTUALIZACIÓN2

Sin embargo, si desea analizar JSON en Office de 64 bits con ScriptControl , esta respuesta puede ayudarlo a ponerlo en funcionamiento.


Como Json no es más que cuerdas, puede manejarse fácilmente si podemos manipularlo de la manera correcta, sin importar cuán compleja sea la estructura. No creo que sea necesario utilizar una biblioteca externa o un convertidor para hacer el truco. Aquí hay un ejemplo en el que he analizado datos JSON utilizando la manipulación de cadenas.

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


Manera más simple puedes ir a array.myitem (0) en código VB

mi respuesta completa aquí analizar y stringificar (serializar)

Usa el objeto ''this'' en js

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

Entonces puedes ir a 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


Muchas gracias Codo.

Acabo de actualizar y completar lo que has hecho para:

  • serializar el json (lo necesito para inyectar el json en un documento de texto)
  • agregar, eliminar y actualizar el nodo (quién sabe)

    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


Otro analizador JSON basado en Regex (solo decodificación)

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


Si desea construir encima de ScriptControl , puede agregar algunos métodos de ayuda para obtener la información requerida. El objeto JScriptTypeInfo es un poco desafortunado: contiene toda la información relevante (como se puede ver en la ventana Inspección ) pero parece imposible acceder a ella con VBA. Sin embargo, el motor de Javascript puede ayudarnos a:

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

Algunas notas:

  • Si la instancia de JScriptTypeInfo hace referencia a un objeto de Javascript, For Each ... Next no funcionará. Sin embargo, funciona si se refiere a una matriz Javascript (vea la función GetKeys ).
  • Las propiedades de acceso cuyo nombre solo se conoce en tiempo de ejecución usan las funciones GetProperty y GetObjectProperty .
  • La matriz Javascript proporciona la length propiedades, 0 , Item 0 , 1 , Item 1 etc. Con la notación de puntos VBA ( jsonObject.property ), solo se puede acceder a la propiedad length y solo si declara una variable llamada length con todas las letras minúsculas. De lo contrario, el caso no coincide y no lo encontrará. Las otras propiedades no son válidas en VBA. Así que es mejor usar la función GetProperty .
  • El código usa enlace anticipado. Por lo tanto, debe agregar una referencia a "Microsoft Script Control 1.0".
  • InitScriptEngine invocar InitScriptEngine una vez antes de usar las otras funciones para realizar una inicialización básica.

Dos pequeñas contribuciones a la respuesta de :

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

Entonces ahora puedo hacer cosas como estas:

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


Esto funciona para mí en Excel y en grandes archivos JSON usando la consulta JSON traducida al formato nativo. https://github.com/VBA-tools/VBA-JSON Puedo analizar el nodo como "item.something" y obtener valor usando un comando simple:

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

Lo que es bueno