Parse json string using Excel VBA

Question

I have the following JSON string. I need to extract the "name" and "id" array values.

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

I am trying to use the code found in Parsing JSON in Excel VBA

The code shared in the link does not parse the json string and ends till to show only the keys(0) as "results" but further, I cannot proceed to get "columns" and further to extract "id", "name".

My environment is Excel 64-bit (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

Hari, what exactly is the problem. Do you get the entire string parsed? What code do you use? I see none in your question. — Luuklag, Oct 05 '18 at 10:07
the entire string was not parsed and I cannot extract the name and id. If you refer to the code in the link I shared, the following two lines do not extract the columns Set JsonObject = DecodeJsonString(CStr(responseText)) Keys = GetKeys(JsonObject) — Hari, Oct 05 '18 at 10:09
Well then please ellaborate on that in your question, as your first problem is parsing the string. Extracting the ID and Name is your second problem. — Luuklag, Oct 05 '18 at 10:11
There is still no code in your question, and no real debugging effort. — Luuklag, Oct 05 '18 at 10:16
I felt like you would refer the code in the link I shared and that gives more information. However, I have updated the question now with the code I am trying and may be you can help. Thanks a lot — Hari, Oct 05 '18 at 10:21
Look at https://github.com/VBA-tools/VBA-JSON...could be useful; — Cylian, Mar 13 '23 at 19:57

QHarr · Accepted Answer · 2018-10-05T11:56:48.460

I believe scriptControl is for 32 bit.

Here I am using a json parser to read your json from a cell A1. After adding in the JSONConverter.bas to the project you need to go VBE > Tools > References > Add check reference for 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

This is the path I am navigating in the JSON Object:

The {} indicated dictionaries accessed by keys. The [] indicate collections accessed by index.

You could also use 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

If you are actually after the "values" collection objects:

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

If you want all the values collections 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

Many thanks for the timely support. While using the split, I cannot get the values of the "name" that are "04-April", "05-May". Any light on this ? — Hari, Oct 05 '18 at 11:32
Hi, the values of "name" are "name" and "id". You are after the "values" collections. — QHarr, Oct 05 '18 at 11:36

Parse json string using Excel VBA

1 Answers1