Невозможно проанализировать строку json, используя код VBA, найденный в stackoverflow - PullRequest
Новая
       12

Невозможно проанализировать строку json, используя код VBA, найденный в stackoverflow

0 голосов
/ 05 октября 2018

У меня есть следующая строка JSON для анализа, и мне нужно извлечь значения массива "name" и "id", 

{"results": [{"columns": [{"name": "name","stringArray": {"values": ["04-April", "05-May"]},"flagsArray": {"values": [15, 15]}}, {"name": "id","longlongArray": {"values": ["244", "245"]},"flagsArray": {"values": [15, 15]}}]}]}

Я только начинающий пользователь VBA и сейчас пытаюсь использоватькод, найденный в стековом потоке,

Синтаксический анализ JSON в Excel VBA

Ваша помощь очень важна для извлечения значений массива "name" и "id".

Кроме того, общий код в ссылке не анализирует строку json и заканчивается до тех пор, пока в качестве «результатов» не отображаются только ключи (0), но далее я не могу продолжить получать «столбцы» и далее извлекать «id», «имя "

Моя среда - 64-разрядная версия Excel (Office 365)

Мы также приветствуем любые другие предложения.

Вот код 

Private ScriptEngine As ScriptControl
Sub InitScriptEngine()
    Set ScriptEngine = CreateObjectx86("MSScriptControl.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 HQL(query As String) As String
InitScriptEngine
Dim responseText As String
Dim JsonString As String
Dim JsonObject As Object
Dim Keys() As String
Dim Keys1() As String
Dim Value As Variant
Dim Value1 As Variant
Dim j As Variant
responseText = "{""results"": [{""columns"": [{""name"": ""name"",""stringArray"": {""values"": [""04-April"", ""05-May""]},""flagsArray"": {""values"": [15, 15]}}, {""name"": ""id"",""longlongArray"": {""values"": [""244"", ""245""]},""flagsArray"": {""values"": [15, 15]}}]}]}"
'responseText = "{""key1"": ""val1"", ""key2"": { ""key3"": ""val3"" } }"
Set JsonObject = DecodeJsonString(CStr(responseText))
Keys = GetKeys(JsonObject)
Value = GetProperty(JsonObject, "results")
Value1 = GetObjectProperty(JsonObject, "columns")
Keys1 = GetKeys(Value1)
MsgBox "Hello"
'End If
End Function
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
Function CreateObjectx86(sProgID)

    Static oWnd As Object
    Dim bRunning As Boolean

    #If Win64 Then
        bRunning = InStr(TypeName(oWnd), "HTMLWindow") > 0
        If IsEmpty(sProgID) Then
            If bRunning Then oWnd.Close
            Exit Function
        End If
        If Not bRunning Then
            Set oWnd = CreateWindow()
            oWnd.execScript "Function CreateObjectx86(sProgID): Set CreateObjectx86 = CreateObject(sProgID): End Function", "VBScript"
        End If
        Set CreateObjectx86 = oWnd.CreateObjectx86(sProgID)
    #Else
        If Not IsEmpty(sProgID) Then Set CreateObjectx86 = CreateObject(sProgID)
    #End If

End Function
Function CreateWindow()

    Dim sSignature, oShellWnd, oProc

    On Error Resume Next
    sSignature = Left(CreateObject("Scriptlet.TypeLib").GUID, 38)
    CreateObject("WScript.Shell").Run "%systemroot%\syswow64\mshta.exe about:""<head><script>moveTo(-32000,-32000);document.title='x86Host'</script><hta:application showintaskbar=no /><object id='shell' classid='clsid:8856F961-340A-11D0-A96B-00C04FD705A2'><param name=RegisterAsBrowser value=1></object><script>shell.putproperty('" & sSignature & "',document.parentWindow);</script></head>""", 0, False
    Do
        For Each oShellWnd In CreateObject("Shell.Application").Windows
            Set CreateWindow = oShellWnd.GetProperty(sSignature)
            If Err.Number = 0 Then Exit Function
            Err.Clear
        Next
    Loop
End Function

1 Ответ

0 голосов
/ 05 октября 2018

Я полагаю, что scriptControl предназначен для 32 бит.

Здесь я использую парсер json для чтения вашего json из ячейки A1.После добавления в проект файла JSONConverter.bas необходимо перейти в VBE> Инструменты> Ссылки> Добавить ссылку проверки для Microsoft Scripting Runtime. 

Public Sub GetInfo()
    Dim jsonStr As String
    jsonStr = [A1]
    Dim json As Object, item As Object
    Set json = JsonConverter.ParseJson(jsonStr)("results")(1)("columns")
    For Each item In json
        Debug.Print item("name")
    Next
End Sub

Это путь, по которому я перемещаюсь в объекте JSON:

image

{} указывает на словари, к которым получают доступ ключи.[] указывает на коллекции, к которым обращается индекс.

Вы также можете использовать Split 

Public Sub GetInfo2()
    Dim jsonStr As String, arr() As String, i As Long
    jsonStr = [A1]
    arr = Split(jsonStr, "name"":")
    If UBound(arr) > 0 Then
    For i = 1 To UBound(arr)
        Debug.Print Split(arr(i), ",")(0)
    Next
    End If
End Sub

Если вы на самом деле ищете объекты коллекций "values": 

Public Sub GetInfo()
    Dim jsonStr As String3
    jsonStr = [A1]
    Dim json As Object, item As Object, key As Variant
    Set json = JsonConverter.ParseJson(jsonStr)("results")(1)("columns")
    For Each item In json
        For Each key In item
           Select Case key
           Case "stringArray", "longlongArray"
               Debug.Print item(key)("values")(1), item(key)("values")(2)
           End Select
        Next
    Next
End Sub

Если вы хотите, чтобы все значения values коллекций: 

Public Sub GetInfo4()
    Dim jsonStr As String
    jsonStr = [A1]
    Dim json As Object, item As Object, key As Variant, key2 As Variant, i As Long
    Set json = JsonConverter.ParseJson(jsonStr)("results")(1)("columns")
    For Each item In json
        For Each key In item
            Select Case TypeName(item(key))
              Case "String"
              Case "Dictionary"
              For Each key2 In item(key)
                  For i = 1 To item(key)(key2).Count
                      Debug.Print item(key)(key2)(i)
                  Next
              Next
            End Select
        Next key
    Next
End Sub
...