代码之家  ›  专栏  ›  技术社区  ›  Lord OfTheRing

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

  •  0
  • Lord OfTheRing  · 技术社区  · 11 月前

    我有下面的函数,它正在格式化我的JSON,但电子邮件并没有按照我喜欢的方式格式化。

    电子邮件的当前输出如下:

    "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
    
    1 回复  |  直到 11 月前
        1
  •  0
  •   Haluk    11 月前

    使用Tim Hall的JSON工具;( https://github.com/VBA-tools/VBA-JSON )

    Sub TestJSON()
        Dim data As Dictionary, email As Dictionary, strJSON As String
    
        Set data = New Dictionary
        Set email = New Dictionary
        
        With data
            .Add "value", "[email protected]"
            .Add "type", "work"
            .Add "primary", True
        End With
        
        email.Add "emails", data
    
        strJSON = JsonConverter.ConvertToJson(ByVal email)
    
        MsgBox strJSON
    End Sub
    

    结果是:;

    {"emails":{"value":"[email protected]","type":"work","primary":true}}
        2
  •  0
  •   Haluk    11 月前

    或者,如果你需要添加一系列电子邮件,那么使用这样的东西。

    显然,您可能需要修改将字典数据添加到集合的方法,因为这只是一个显示机制的示例。

    Sub TestJSON2()
        Dim data As Dictionary, email As Collection, JSON_data As Dictionary, strJSON As String
    
        Set email = New Collection
        
        Set data = New Dictionary
        
        With data
            .Add "value", "[email protected]"
            .Add "type", "work"
            .Add "primary", True
        End With
        
        email.Add data
        
        Set data = New Dictionary
        
        With data
            .Add "value", "[email protected]"
            .Add "type", "Home"
            .Add "primary", False
        End With
        
        email.Add data
        
        Set data = New Dictionary
        
        With data
            .Add "value", "[email protected]"
            .Add "type", "work"
            .Add "primary", True
        End With
        
        email.Add data
        
        Set JSON_data = New Dictionary
        JSON_data.Add "emails", email
        
        strJSON = JsonConverter.ConvertToJson(ByVal JSON_data, 2)
    
        MsgBox strJSON
    End Sub
    
    

    结果如下:;

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