Te damos la bienvenida a nuestra página web, ahora vas a hallar la resolución de lo que buscas.
Solución:
Si quieres construir sobre ScriptControl, puede agregar algunos métodos auxiliares para obtener la información requerida. los JScriptTypeInfo El objeto es un poco desafortunado: contiene toda la información relevante (como puede ver en la Mirar window) pero parece imposible hacerlo con VBA. Sin embargo, el motor 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 el
JScriptTypeInfoinstancia se refiere a un objeto Javascript,For Each ... Nextno funcionará. Sin embargo, funciona si se refiere a una matriz de Javascript (consulteGetKeysfunción). - Las propiedades de acceso cuyo nombre solo se conoce en tiempo de ejecución, utilizan las funciones
GetPropertyyGetObjectProperty. - La matriz de Javascript proporciona las propiedades
length,0,Item 0,1,Item 1etc. Con la notación de puntos VBA (jsonObject.property), solo se puede acceder a la propiedad length y solo si declara una variable llamadalengthcon 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 mejor usa elGetPropertyfunción. - El código usa enlace anticipado. Por lo tanto, debe agregar una referencia a “Microsoft Script Control 1.0”.
- Tienes que llamar
InitScriptEngineuna vez antes de usar las otras funciones para realizar una inicialización básica.
ACTUALIZACIÓN 3 (24 de septiembre de 2017)
Consulte VBA-JSON-parser en GitHub para obtener la última versión y ejemplos. Importe el módulo JSON.bas en el proyecto VBA para el procesamiento JSON.
ACTUALIZACIÓN 2 (1 de octubre de 2016)
Sin embargo, si desea analizar JSON en Office de 64 bits con ScriptControl, entonces esta respuesta puede ayudarlo a obtener ScriptControl para trabajar en 64 bits.
ACTUALIZAR (26 de octubre de 2015)
Tenga en cuenta que un ScriptControlLos enfoques basados en datos hacen que el sistema sea vulnerable en algunos casos, ya que permiten un 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 JSON del servidor web, 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 JSON analizando con ScriptControl ActiveX no es una buena idea.
Tratando de evitar eso, he creado un analizador JSON basado en RegEx. Objetos están representados por diccionarios, lo que hace posible utilizar las propiedades y métodos del diccionario: .Count, .Exists(), .Item(), .Items, .Keys. Matrices [] son los arreglos VB convencionales de base cero, por lo que UBound() muestra el número 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 "desktopsource.json" file
' processed JSON will be saved to "desktopresult.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 = "<" & 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 = ""
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
Una oportunidad más de este analizador JSON RegEx es que funciona en Office de 64 bits, donde ScriptControl no está disponible.
INICIAL (27 de mayo de 2015)
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
Como Json no es más que cadenas, 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 ninguna biblioteca o convertidor externo para hacer el truco. Aquí hay un ejemplo en el que analicé 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
Sección de Reseñas y Valoraciones
Al final de todo puedes encontrar las observaciones de otros usuarios, tú incluso puedes dejar el tuyo si te apetece.
¡Haz clic para puntuar esta entrada!
(Votos: 0 Promedio: 0)