Search code examples
vbams-accesselixir-jason

Email is not adding [ and ] bracket in VBA for Json format


I have below function which is formatting my JSON, but email is not being formatted the way I like.

Current output for email is like this:

"emails": "[email protected]",

but I am looking for this format instead:

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

How do I fix the code in 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

Solution

  • Using Tim Hall's JSON tool; (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
    

    The result is;

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