create JSON using JSONCOVERTER - json

Question

I am wondering to create a json from VBA Outlook to export email as ticket on Osticket System
Everithing working well except when there's multiple attachments
I need to have this syntax
{
"alert": "true",
"autorespond": "true",
"source": "API",
"name": "Angy User",
"email": "Angry#somewhere.com",
"subject": "Help",
"topicId": "1",
"message": "data:text/html,</body></html>Please Help</body></html>",
"attachments": [
{ "MyFile.png": "data:image/png;base64,JVBERi0........." },
{ "MyFile.png": "data:image/png;base64,JVBERi0........." },
]
}
But using my code i get this
{
"alert": "true",
"autorespond": "true",
"source": "API",
"name": "Angy User",
"email": "Angry#somewhere.com",
"subject": "Help",
"topicId": "1",
"message": "data:text/html,</body></html>Please Help</body></html>",
"attachments": [
{ "MyFile.png": "data:image/png;base64,JVBERi0.........",
"MyFile.png": "data:image/png;base64,JVBERi0........." },
]
}
I use this to create the json
Dim Body As New Dictionary
Body.Add "alert", "true"
Body.Add "autorespond", "true"
Body.Add "source", "API"
Body.Add "name", myMsg.SenderName
Body.Add "email", FromAddress
Body.Add "subject", myMsg.Subject
Body.Add "topicId", CStr(rubriq)
Body.Add "message", "data:text/html," & strData 'myMsg.HTMLBody
Body.Add "attachments", Array(Attm1) 'attachments
Dim json As String
json = JsonConverter.ConvertToJson(Body, Whitespace:=" ")
Where the Attm1 is a dictionary filled in FOR loop
Attm1.Add oFile.FileName, "data:" & _
oFile.PropertyAccessor.GetProperty(PR_ATTACH_CONTENT_TYPE) & _
";" & "base64," & n.nodeTypedValue
I used this function
https://github.com/VBA-tools/VBA-JSON
The loop code
Dim attachments As New Collection
If myMsg.attachments.Count > 0 Then
Set fs = CreateObject("Scripting.FileSystemObject")
Set nAtt = xmlTicket.createElement("attachments")
nodeTicket.appendChild nAtt
For i = 1 To myMsg.attachments.Count
Set oFile = myMsg.attachments.Item(i)
'I only add attachments up to a limit in size
If oFile.Size <= MAX_ATTACHMENT Then
sTmpFile = fs.GetTempName
oFile.SaveAsFile sTmpFile
'Attachment data is always base64-coded
n.dataType = "bin.base64"
'The ADODB.Stream tweak allows to read binary files
Set data = CreateObject("ADODB.Stream")
data.Type = 1 'Binary
data.Open
data.LoadFromFile sTmpFile
'MSXML will base64-code it for us
n.nodeTypedValue = data.Read
'Using the bin.base64 structure means adding namespace'd attributes.
'For some reason, osTicket will complain for each extra attribute, so
'we get to clean up
n.Attributes.removeNamedItem "dt:dt"
'For some reason, getting the content-type is very unclear in Outlook
Set a = xmlTicket.createAttribute("type")
a.Value = oFile.PropertyAccessor.GetProperty(PR_ATTACH_CONTENT_TYPE)
n.Attributes.setNamedItem a
Dim Attm1 As New Dictionary
Attm1.Add oFile.FileName, "data:" & oFile.PropertyAccessor.GetProperty(PR_ATTACH_CONTENT_TYPE) & ";" & "base64," & n.nodeTypedValue
Kill sTmpFile
End If
Next
End If

Answer 1

Try something like this. It's easier to manage if you split out the various jobs into separate methods.
Const MAX_ATTACHMENT As Long = 500000 'or whatever
Sub MainSub()
Dim Body As Object, dict As Object, i As Long, json As String
Dim myMsg As Outlook.MailItem
'...
'...
Body.Add "attachments", New Collection
If myMsg.attachments.Count > 0 Then
For i = 1 To myMsg.attachments.Count
Set dict = AttachmentDict(myMsg.attachments.Item(i))
If Not dict Is Nothing Then 'check conversion happened
Body("attachments").Add dict
End If
Next
End If
json = JsonConverter.ConvertToJson(Body, Whitespace:=" ")
'...
'...
End Sub
'create a dictionary from an attachment if it meets the size limit
Function AttachmentDict(att As Outlook.Attachment)
Dim dict As Object, fso As Object, sTmpFile As String
If att.Size < MAX_ATTACHMENT Then
Set dict = CreateObject("Scripting.Dictionary")
Set fso = CreateObject("Scripting.FileSystemObject")
sTmpFile = fso.GetSpecialFolder(2) & "\" & fso.GetTempName
att.SaveAsFile sTmpFile
dict.Add att.Filename, "data:" & _
att.PropertyAccessor.GetProperty(PR_ATTACH_CONTENT_TYPE) & _
";" & "base64," & FileToBase64(sTmpFile)
Set AttachmentDict = dict
End If
End Function
Function FileToBase64(FilePath As String) As String
Const adTypeBinary = 1 ' Binary file is encoded
Dim objXML, objDocElem, objStream
' Open data stream from file
Set objStream = CreateObject("ADODB.Stream")
objStream.Type = adTypeBinary
objStream.Open
objStream.LoadFromFile FilePath
Set objXML = CreateObject("MSXml2.DOMDocument")
Set objDocElem = objXML.createElement("Base64Data")
objDocElem.DataType = "bin.base64"
objDocElem.nodeTypedValue = objStream.Read()
FileToBase64 = objDocElem.Text
End Function