Excel VBA crée une charge utile json

Vous avez un problème structurel en ce que chaque fois que vous appelez votre sous pour créer le JSON, les valeurs précédentes sont écrasées. Cependant, l'exemple ci-dessous devrait aider à dissiper la confusion que vous avez lors de la création de la structure JSON de base. Je recommande fortement d'utiliser des noms de variables plus descriptifs (comme dans l'exemple) pour créer moins de confusion.

Cet exemple de code créera un bloc correctement formaté, mais comme je l'ai mentionné, vous devrez retravailler votre logique pour vous assurer toutes les lignes sont correctement ajoutées.

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

Utilisation de quelques fonctions d'aide pour simplifier la 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

Voici un exemple VBA montrant comment convertir des paramètres "plats" en chaîne JSON de charge utile. Importez le module JSON.bas dans le projet VBA pour le traitement JSON. fort>

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