У меня есть функция ниже, которая форматирует мой 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
Использование инструмента 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}]}