json - Excel VBA 创建 json 有效负载

Question

我正在使用 Excel VBA 并调用外部 rest api。该调用需要一个 json 格式的有效负载。我在创建 json 格式时遇到问题。

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

vba 代码如下:

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

我面临的问题是如何创建这个 json 有效负载。以下结构在 d2.Add f1 失败

你能告诉我如何构建这个 json

Answer 1

这是 VBA 示例，展示了如何将“平面”参数转换为有效负载 JSON 字符串。 进口 JSON.bas模块到 VBA 项目中进行 JSON 处理。

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