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

How exactly is it failing?

Tim Williams
– Tim Williams

2020-01-02 22:13:23 +00:00
Commented Jan 2, 2020 at 22:13 — Tim Williams
– Tim Williams, Commented Jan 2, 2020 at 22:13

Tim Williams · Accepted Answer · 2020-01-02 23:23:40Z

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

omegastripes · Accepted Answer · 2020-01-03 23:07:46Z

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

PeterT · Accepted Answer · 2020-01-02 22:25:59Z

You have a structural problem in that each time you call your sub to create the JSON, the previous values are overwritten. However, the example below should help clear up the confusion you have in creating the basic JSON structure. I strongly recommend using more descriptive variable names (as in the example) to create less confusion.

This example code will create a correctly formatted block, but as I mentioned, you'll have to re-work your logic to make sure all of the rows are properly added.

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

    Dim identDetails As Dictionary
    Set identDetails = New Dictionary
    With identDetails
        .Add "apiName", apiName
        .Add "value", apiName_value
    End With

    Dim identifiers As Collection
    Set identifiers = New Collection
    identifiers.Add identDetails

    Dim custContext As Dictionary
    Set custContext = New Dictionary
    With custContext
        .Add "identifiers", identDetails
        .Add "baseTouchpointUri", baseTouchpoint
    End With

    Dim activities As Collection
    Set activities = New Collection

    Dim activityDetails As Dictionary
    Set activityDetails = New Dictionary
    With activityDetails
        .Add "propositionCode", propositionCode
        .Add "activityTypeCode", activityTypeCode
        .Add "timestamp", timestamp
    End With
    activities.Add activityDetails

    Dim root As Dictionary
    Set root = New Dictionary
    With root
        .Add "customerContext", custContext
        .Add "activities", activities
    End With

    CreateJSONBlock = JsonConverter.ConvertToJson(root)
End Function

Collectives™ on Stack Overflow

Excel VBA create json payload

3 Answers 3

Comments

Comments

Comments

Your Answer

Linked

Hot Network Questions

Collectives™ on Stack Overflow

3 Answers 3

Comments

Comments

Comments

Your Answer

Sign up or log in

Post as a guest

Linked

Related