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": "[email protected]",
 "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": "[email protected]",
 "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

CodePudding user response：

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