VBA生成JSON时邮箱字段未添加[]数组格式如何修复

当前代码中emails字段被直接设置为单个字典对象，而SCIM规范要求该字段是包含邮箱对象的数组，同时primary字段需要是布尔值而非字符串。按以下方式修改即可得到预期格式：

具体修改点 #

找到create user分支下的emails相关代码，替换为：

' 创建单个邮箱对象
Dim emailObj As Object
Set emailObj = CreateObject("Scripting.Dictionary")
With emailObj
    .Add "value", "<WORK EMAIL>"
    .Add "type", "work"
    .Add "primary", True ' 改为布尔值，而非字符串
End With
' 将邮箱对象放入数组，赋值给emails字段
requestBody("emails") = Array(emailObj)

修改后的完整代码 #

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>"
        
        ' 修改emails字段为数组格式
        Dim emailObj As Object
        Set emailObj = CreateObject("Scripting.Dictionary")
        With emailObj
            .Add "value", "<WORK EMAIL>"
            .Add "type", "work"
            .Add "primary", True
        End With
        requestBody("emails") = Array(emailObj)
        
        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

修改说明 #

1. 将单个邮箱字典对象包装进Array()，使emails输出为JSON数组格式
2. 将primary字段的值从字符串"true"改为VBA布尔值True，确保JSON输出为布尔类型true而非字符串

内容的提问来源于stack exchange，提问作者Lord OfTheRing