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 失败。添加 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

Answer 2

使用一些辅助函数来简化构造：

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 3

您有一个结构性问题，即每次调用 sub 来创建 JSON 时，之前的值都会被覆盖。但是，下面的示例应该有助于消除您在创建基本 JSON 结构时的困惑。我强烈建议使用更具描述性的变量名称（如示例中所示）以减少混淆。

此示例代码将创建一个格式正确的块，但正如我所提到的，您必须重新设计逻辑以确保正确添加所有行。

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