使用JSONCOVERTER創建JSON

我想知道從 VBA Outlook 創建一個 json 以將電子郵件匯出為 Osticket 系統上的票據 Everithing 作業良好，除非有多個附件

我需要有這個語法

{
 "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........."  },
 ]
}

但是使用我的代碼我得到了這個

{
 "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........."  },
 ]
}

我用它來創建 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:=" ")

其中 Attm1 是在 FOR 回圈中填充的字典

Attm1.Add oFile.FileName, "data:" & _
    oFile.PropertyAccessor.GetProperty(PR_ATTACH_CONTENT_TYPE) & _
    ";" & "base64," & n.nodeTypedValue

我用過這個功能

https://github.com/VBA-tools/VBA-JSON

回圈代碼

      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

uj5u.com熱心網友回復：

嘗試這樣的事情。如果將各種作業拆分為單獨的方法，則管理起來會更容易。

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

標籤：JSONVBA外表

上一篇：回圈計數器以增加變數值

下一篇：VBA使用變數呼叫單元格