电子邮件未在 Jason 格式的 VBA 中添加 [ 和 ] 括号

Question

我有以下功能正在格式化我的 Jason，但电子邮件的格式不符合我喜欢的方式。电子邮件的当前输出如下：

"emails": "[email protected]",

但我正在寻找以下格式：

"emails":[  
    {  
        "value":"[email protected]",
        "type":"work",
        "primary":true
    }
],

如何修复 VBA 中的代码？

Function GetRequestBody(requestType As String, Optional includeOptional As Boolean = False) As Object
    Dim requestBody As Object
    Set requestBody = CreateObject("Scripting.Dictionary")

    If LCase(requestType) = "http return" Then
        requestBody("status") = "<HTTP STATUS CODE>"
        requestBody("raw") = "<JSON>"
        requestBody("message") = "<HTTP RESPONSE>"
        Set GetRequestBody = requestBody
        Exit Function
    ElseIf LCase(requestType) = "create user" Then
        requestBody("schemas") = Array("ietf:params:scim:schemas:core:2.0:User", "urn:ietf:params:scim:schemas:extension:enterprise:2.0:User")
        requestBody("userName") = "<REQ ID>"
        Set requestBody("name") = CreateObject("Scripting.Dictionary")
        With requestBody("name")
            .Add "givenName", "<FIRST NAME>"
            .Add "familyName", "<LAST NAME>"
        End With
        requestBody("displayName") = "<DISPLAY NAME>"
        Set requestBody("emails") = CreateObject("Scripting.Dictionary")
        With requestBody("emails")
            .Add "value", "<WORK EMAIL>"
            .Add "type", "work"
            .Add "primary", "true"
        End With
        
        Set requestBody("roles") = CreateObject("Scripting.Dictionary")
        Set requestBody("groups") = CreateObject("Scripting.Dictionary")
        Set requestBody("urn:scim:schemas:extension:enterprise:1.0") = CreateObject("Scripting.Dictionary")
        With requestBody("urn:scim:schemas:extension:enterprise:1.0")
            Set .Item("manager") = CreateObject("Scripting.Dictionary")
            .Item("manager")("managerId") = "<MANAGER ID>"
        End With

        If includeOptional Then
            Set requestBody("urn:ietf:params:scim:schemas:extension:sap:user-custom-parameters:1.0") = CreateObject("Scripting.Dictionary")
            With requestBody("urn:ietf:params:scim:schemas:extension:sap:user-custom-parameters:1.0")
                .Add "dataAccessLanguage", "en"
                .Add "dateFormatting", "MMM d, yyyy"
                .Add "timeFormatting", "H:mm:ss"
                .Add "numberFormatting", "1,234.56"
                .Add "cleanUpNotificationsNumberOfDays", 0
                .Add "systemNotificationsEmailOptIn", "true"
                .Add "marketingEmailOptIn", "false"
                .Add "isConcurrent", "true"
            End With
        End If
    ElseIf LCase(requestType) = "create team" Then
        requestBody("id") = "<TEAM ID>"
        requestBody("displayName") = "<TEAM DESC>"
        Set requestBody("members") = CreateObject("Scripting.Dictionary")
        With requestBody("members")
            .Add "type", "User"
            .Add "value", " <USER ID> "
            .Add "$ref", "/api/v1/scim/Users/<USER ID> "
        End With
        Set requestBody("roles") = CreateObject("Scripting.Dictionary")
        If includeOptional Then
            Set requestBody("urn:ietf:params:scim:schemas:extension:sap:group-custom-parameters:1.0") = CreateObject("Scripting.Dictionary")
            With requestBody("urn:ietf:params:scim:schemas:extension:sap:group-custom-parameters:1.0")
                .Add "admins", Array("User1")
                .Add "moderators", Array("User1", "User2")
            End With
        End If
    ElseIf LCase(requestType) = "add user" Then
        requestBody("type") = "User"
        requestBody("value") = " <USER ID> "
        requestBody("$ref") = "/api/v1/scim/Users/<USER ID>"
    ElseIf LCase(requestType) = "add team" Then
        requestBody("value") = "<TEAM ID>"
        requestBody("display") = "<TEAM TEXT>"
        requestBody("$ref") = "/api/v1/scim/Groups/<TEAM ID>"
    ElseIf LCase(requestType) = "add email" Then
        requestBody("value") = "<EMAIL>"
        requestBody("type") = "<TYPE>"
        requestBody("primary") = "<VALUE>"
    End If

    Set GetRequestBody = requestBody
End Function

Answer 1

使用 Tim Hall 的 JSON 工具；

子测试JSON()
    暗淡数据作为字典，电子邮件作为字典，strJSON 作为字符串

    设置数据=新词典
    设置电子邮件=新词典
    
    有数据
        .添加“值”、“[电子邮件受保护]”
        .添加“类型”、“工作”
        .添加“主要”，True
    结束于
    
    电子邮件。添加“电子邮件”、数据

    strJSON = JsonConverter.ConvertToJson(ByVal 电子邮件)

    MsgBox strJSON
结束子