CODEWITHSUNDEEP
jsonexcelvbascriptcontrol
davor.geci
davor.geci

Reputation: 91

Reading a JSON and looping in VBA

I'm getting from the server a JSON string with the statuses of a particular actions. In this case it returns results for 2 actions. For ID: 551720 and ID: 551721

String looks like this:

[{"ElectronicId":551720,"DocumentNr":"130/10/15",
"DocumentTypeId":1,"DocumentTypeName":"eInvoice",
"StatusId":30,"StatusName":"Sent","RecipientBusinessNumber":"0050960000",
"RecipientBusinessUnit":"","RecipientBusinessName":"Comp d.o.o.",
"Created":"2019-07-23T21:21:23.743","Updated":"2019-07-23T21:21:24.587",
"Sent":"2019-07-23T21:21:24.587","Delivered":null},
{"ElectronicId":551721,"DocumentNr":"130/10/15",
"DocumentTypeId":1,"DocumentTypeName":"eInvoice",
"StatusId":30,"StatusName":"Sent","RecipientBusinessNumber":"00509605454",
"RecipientBusinessUnit":"","RecipientBusinessName":"Comp d.o.o.",
"Created":"2019-07-23T21:23:05.887","Updated":"2019-07-23T21:23:07.043",
"Sent":"2019-07-23T21:23:07.043","Delivered":null}]

Sometimes it returns 1, sometimes 2, or maybe 20 statuses (different "ElectronicId")

How could I loop within JSON. I have a code that works when I have only 1 response, but it doesn't work when I have more than 1. Here is the code for 1 response:

Dim cJS As New clsJasonParser

 cJS.InitScriptEngine

results = """""here goes the JSON string""""""

 Set JsonObject = cJS.DecodeJsonString(CStr(result))


        Debug.Print cJS.GetProperty(JsonObject, "ElectronicId")
        Debug.Print cJS.GetProperty(JsonObject, "DocumentNr")
        Debug.Print cJS.GetProperty(JsonObject, "DocumentTypeId")
        Debug.Print cJS.GetProperty(JsonObject, "DocumentTypeName")
        Debug.Print cJS.GetProperty(JsonObject, "StatusId")

Here is the code for the clsJasonParser bClass:

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

Upvotes: 0

Views: 405

Answers (1)

QHarr
QHarr

Reputation: 84465

I would use jsonconverter.bas to parse the json. After installing the code from that link in a standard module called JsonConverter, go to VBE > Tools > References > Add a reference to Microsoft Scripting Runtime.

Then I would dimension an array to hold the results. I would determine rows from the number of items in the json collection returned and the number of columns from the size of the first item dictionary. Loop the json object, and inner loop the dictionary keys of each dictionary in collection, and populate the array. Write the array out in one go at end.

Below, I am reading in the json string from cell A1 but you would replace that with your json source.

Option Explicit
Public Sub test()
    Dim json As Object, r As Long, c As Long, headers()
    Dim results(), ws As Worksheet, item As Object, key As Variant

    Set ws = ThisWorkbook.Worksheets("Sheet1")
    Set json = JsonConverter.ParseJson(ws.[A1].Value)  '<Reading json from cell. Returns collection
    headers = json.item(1).keys  'each item in collection is a dictionary. Use .keys to get headers for results e.g. ElectronicId
    ReDim results(1 To json.Count, 1 To UBound(headers) + 1)
    For Each item In json 'loop json and populate results array
        r = r + 1: c = 1
        For Each key In item.keys
            results(r, c) = item(key)
            c = c + 1
        Next
    Next
    With ws
        .Cells(2, 1).Resize(1, UBound(headers) + 1) = headers
        .Cells(3, 1).Resize(UBound(results, 1), UBound(results, 2)) = results
    End With
End Sub

Upvotes: 3

Related Questions