Excel VBA create json payload

Question

I am using Excel VBA and calling a external rest api. The call needs a payload which is in json format. i am facing problem creating the json format.

{
   "customerContext": {
      "identifiers": [
         {
            "apiName": "email",
            "value": "[email protected]"
         }
      ],
      "baseTouchpointUri": "physical://webinar"
   },
   "activities": [
      {
         "propositionCode": "Homepage",
         "activityTypeCode": "ATTEND_ROADSHOW",
         "timestamp": "2019-12-27T10:31:40Z"
      }
   ]
}

The vba code is as follows :

Sub UploadOfflineInteraction()

    Dim apiName As String
    Dim apiName_value As String
    Dim baseTouchpoint As String
    Dim propositionCode As String
    Dim activityTypeCode As String
    Dim timestamp As String
    Dim NoOfRows As Integer
    Dim i As Integer


    ActiveWorkbook.Worksheets("Data").Activate
    NoOfRows = ActiveWorkbook.Worksheets("Data").Range("A2").End(xlDown).row

    For i = 1 To NoOfRows
        apiName = ActiveWorkbook.Worksheets("Data").Cells(i, 1).Value
        apiName_value = ActiveWorkbook.Worksheets("Data").Cells(i, 2).Value
        baseTouchpoint = ActiveWorkbook.Worksheets("Data").Cells(i, 3).Value
        propositionCode = ActiveWorkbook.Worksheets("Data").Cells(i, 4).Value
        activityTypeCode = ActiveWorkbook.Worksheets("Data").Cells(i, 5).Value
        timestamp = ActiveWorkbook.Worksheets("Data").Cells(i, 6).Value
        Dim tid
        tid = SentOfflineInteraction(apiName, apiName_value, baseTouchpoint, propositionCode, activityTypeCode, timestamp)
    Next i

End Sub

Function SentOfflineInteraction(apiName As String, apiName_value As String, _
              baseTouchpoint As String, propositionCode As String, _
              activityTypeCode As String, timestamp As String) As String

    Dim c As Collection
    Dim d As Dictionary
    Dim e As Dictionary
    Dim f As Dictionary
    Dim json As String

    Set c = New Collection
    Set d = New Dictionary
    Set e = New Dictionary
    Set f = New Dictionary

    d.Add "propositionCode", propositionCode
    d.Add "activityTypeCode", activityTypeCode
    d.Add "timestamp", timestamp
    c.Add d
    f.Add "activities", c

    Dim c1 As Collection
    Dim d1 As Dictionary
    Dim e1 As Dictionary
    Dim f1 As Dictionary

    Set c1 = New Collection
    Set d1 = New Dictionary
    Set e1 = New Dictionary
    Set f1 = New Dictionary

    d1.Add "apiName", apiName
    d1.Add "value", apiName_value
    c1.Add d1
    f1.Add "identifiers", c1

    Dim c2 As Collection
    Dim d2 As Dictionary
    Dim e2 As Dictionary
    Dim f2 As Dictionary

    Set c2 = New Collection
    Set d2 = New Dictionary
    Set e2 = New Dictionary
    Set f2 = New Dictionary

    d2.Add f1
    d2.Add "baseTouchpointUri", baseTouchpoint
    c2.Add d2
    f2.Add "customerContext", c2


    Dim c3 As Collection
    Dim d3 As Dictionary
    Dim e3 As Dictionary
    Dim f3 As Dictionary

    Set c3 = New Collection
    Set d3 = New Dictionary
    Set e3 = New Dictionary
    Set f3 = New Dictionary

    d3.Add f2
    d3.Add f1
    c3.Add d3

    json = JsonConverter.ConvertToJson(ByVal c3)

    Debug.Print json

End Function

The problem i am facing is how to create this json payload . the below struture is failing at d2.Add f1

could you let me know how to build this json

Answer 1

Using some helper functions to simplify the construction:

Sub UploadOfflineInteraction()

    Dim i As Long, cntxt As Object, act As Object, o As Object

    With ActiveWorkbook.Worksheets("Data")
        For i = 1 To .Cells(.rows.Count, 1).End(xlUp).Row
            With .rows(i)
                Set cntxt = jsonobject("identifiers", _
                                       jsonarray(jsonobject("apiName", .Cells(1).Value, _
                                                            "value", .Cells(2).Value)), _
                                       "baseTouchpointUri", .Cells(3).Value)

                Set act = jsonarray(jsonobject("propositionCode", .Cells(4).Value, _
                                               "activityTypeCode", .Cells(5).Value, _
                                               "timestamp", .Cells(6).Value))


                Set o = jsonobject("customerContext", cntxt, "activities", act)

                Debug.Print JsonConverter.ConvertToJson(o, 2)

            End With
        Next i
    End With

End Sub


'return a dictionary given a paramarray of key_1,value_1,...,key_n,value_n
Function jsonobject(ParamArray keyvals()) As Object
    Dim rv As Object, n As Long
    Set rv = CreateObject("scripting.dictionary")
    For n = LBound(keyvals) To UBound(keyvals) Step 2
        rv.Add keyvals(n), keyvals(n + 1)
    Next n
    Set jsonobject = rv
End Function
'return a collection from a paramarray of values
Function jsonarray(ParamArray vals()) As Collection
    Dim rv As New Collection, n As Long
    For n = LBound(vals) To UBound(vals)
        rv.Add vals(n)
    Next n
    Set jsonarray = rv
End Function

Answer 2

Here is VBA example showing how to convert "flat" parameters to payload JSON string. Import JSON.bas module into the VBA project for JSON processing.

Option Explicit

' Need to include a reference to "Microsoft Scripting Runtime"

Sub UploadOfflineInteraction()

    With ActiveWorkbook.Worksheets("Data")
        Dim i As Long
        For i = 1 To .Cells(.Rows.Count, 1).End(xlUp).Row
            Dim flat As Dictionary
            Set flat = New Dictionary
            With .Cells(i, 1)
                flat("customerContext.identifiers[0].apiName") = .Offset(, 0).Value
                flat("customerContext.identifiers[0].value") = .Offset(, 1).Value
                flat("customerContext.baseTouchpointUri") = .Offset(, 2).Value
                flat("activities[0].propositionCode") = .Offset(, 3).Value
                flat("activities[0].activityTypeCode") = .Offset(, 4).Value
                flat("activities[0].timestamp") = .Offset(, 5).Value
            End With
            Dim params
            Dim success As Boolean
            JSON.Unflatten flat, params, success
            Dim payload As String
            payload = JSON.Serialize(params)
            Debug.Print payload
        Next
    End With

End Sub