Excel VBA 创建 json 有效负载 [英] Excel VBA create json payload

问题描述

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

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": "[e-mail]"
         }
      ],
      "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 处失败

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

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

could you let me know how to build this json

推荐答案

使用一些辅助函数来简化构建:

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

这篇关于Excel VBA 创建 json 有效负载的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！