Электронная почта не добавляет скобки [ и ] в формате VBA для Json

У меня есть функция ниже, которая форматирует мой 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
Стоит ли изучать PHP в 2023-2024 годах?
Стоит ли изучать PHP в 2023-2024 годах?
Привет всем, сегодня я хочу высказать свои соображения по поводу вопроса, который я уже много раз получал в своем сообществе: "Стоит ли изучать PHP в...
Поведение ключевого слова "this" в стрелочной функции в сравнении с нормальной функцией
Поведение ключевого слова "this" в стрелочной функции в сравнении с нормальной функцией
В JavaScript одним из самых запутанных понятий является поведение ключевого слова "this" в стрелочной и обычной функциях.
Приемы CSS-макетирования - floats и Flexbox
Приемы CSS-макетирования - floats и Flexbox
Здравствуйте, друзья-студенты! Готовы совершенствовать свои навыки веб-дизайна? Сегодня в нашем путешествии мы рассмотрим приемы CSS-верстки - в...
Тестирование функциональных ngrx-эффектов в Angular 16 с помощью Jest
В системе управления состояниями ngrx, совместимой с Angular 16, появились функциональные эффекты. Это здорово и делает код определенно легче для...
Концепция локализации и ее применение в приложениях React ⚡️
Концепция локализации и ее применение в приложениях React ⚡️
Локализация - это процесс адаптации приложения к различным языкам и культурным требованиям. Это позволяет пользователям получить опыт, соответствующий...
Пользовательский скаляр GraphQL
Пользовательский скаляр GraphQL
Листовые узлы системы типов GraphQL называются скалярами. Достигнув скалярного типа, невозможно спуститься дальше по иерархии типов. Скалярный тип...
0
0
63
2
Перейти к ответу Данный вопрос помечен как решенный

Ответы 2

Ответ принят как подходящий

Использование инструмента 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}}

Или, если вам нужно добавить массив электронных писем, используйте что-то вроде этого.

Очевидно, вам может потребоваться пересмотреть метод добавления словарных данных в коллекцию, поскольку это всего лишь пример, демонстрирующий механизм.

 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}]}

Другие вопросы по теме