ms-access - 使用 API (VBA) 的 SendGrid 附件为空或损坏

Question

这似乎是 SendGrid Web API 和电子邮件附件的一个常见问题。我在网络上发现了很多帖子，他们都遇到了同样的问题……但似乎没有一个能得到解决方案。 SendGrid 自己的 jar 头回应是使用他们的库之一......但问题仍然是当您使用没有库的语言时如何附加文件。

我已经尝试就此问题联系 SendGrid 支持人员……甚至提出支付支持费用以获得答案，但他们认为我要求的是“代码审查”，但我没有。问题很简单:将附件上传到 SendGrid Web API 需要什么。

我以前只是在建议的 API 格式中提供文件位置，如下所示:Previous Example of Posting to SendGrid Using VBA这对我自己和其他几个人来说似乎工作了一段时间......但最近有些事情发生了变化。提供简单的文件路径似乎不再有效。那我现在需要做什么？我应该对文件进行编码吗？如果是这样，我应该使用 base64 什么编码？我和其他许多人将不胜感激!

这是我的 base64 尝试，但它与我之前的文件路径尝试有同样的问题，即附件显示在电子邮件中......但它无法打开。

Private Sub SendEmail()
    Dim rs As DAO.Recordset
    Dim SQL As String
    Dim byteData() As Byte
    Dim xmlhttp As Object
    Dim eTo As String
    Dim eFrom As String
    Dim eBody As String
    Dim eSubject As String
    Dim eToName As String
    Dim HttpReq As String
    Dim ePass As String
    Dim eUser As String
    Dim strXML As String
    Dim strAttachments As String
    Dim strBase64 As String



    eSubject = Me.txtSubject
    eBody = Me.txtMessage
    eFrom = SenderEmail
    eUser = SendGridUser
    ePass = SendGridPass

    ' If Groups List/ Else Contacts List
    If Me.chkGroups <> 0 Then
        SQL = "SELECT * FROM qryContactsInSelectedGroups WHERE ContactType = 'Email'"
    Else
        SQL = "SELECT * FROM qrySelectedContacts WHERE ContactType = 'Email'"
    End If
    Set rs = CurrentDb.OpenRecordset(SQL, dbOpenDynaset, dbSeeChanges)

    If Not (rs.EOF And rs.BOF) Then
        rs.MoveFirst
        Do Until rs.EOF = True
            eTo = rs.Fields("ContactValue").Value
            eToName = rs.Fields("FirstName").Value & " " & rs.Fields("LastName").Value

              ' Set the Server URL to the form input
            HttpReq = "https://api.sendgrid.com/api/mail.send.xml?" _
            & "api_user=" & eUser _
            & "&api_key=" & ePass _
            & "&to=" & eTo _
            & "&toname=" & eToName _
            & "&subject=" & eSubject _
            & "&text=" & eBody _
            & "&from=" & eFrom _
            & GetAttachments()
            ' files[file1.jpg]=file1.jpg&files[file2.pdf]=file2.pdf
            Set xmlhttp = CreateObject("MSXML2.XMLHTTP")
           ' adoStream.Position = 0
            xmlhttp.Open "POST", HttpReq, False
            xmlhttp.send

            byteData = xmlhttp.responseBody

            Set xmlhttp = Nothing
            strXML = StrConv(byteData, vbUnicode)
            Call EmailResponse(strXML, rs.Fields("ContactID").Value)
            Debug.Print strXML
            rs.MoveNext
        Loop
    End If
    Set rs = Nothing
End Sub

    Private Function GetAttachments() As String
    Dim rs As DAO.Recordset
    Dim SQL As String
    Dim currentAttachment As String
    Dim strAttachments As String
    Dim Encoded64 As String

    SQL = "SELECT * FROM tblMessageAttachments WHERE [MessageID] = " & MessageID
    Set rs = CurrentDb.OpenRecordset(SQL, dbOpenDynaset, dbSeeChanges)

    If Not (rs.EOF And rs.BOF) Then
        rs.MoveFirst
        Do Until rs.EOF = True
            ' Set Current Attachment
            currentAttachment = rs.Fields("AttachmentLocation").Value & rs.Fields("AttachmentName").Value
            Encoded64 = EncodeFile(currentAttachment)
            strAttachments = strAttachments & "&files" & Chr(91) & rs.Fields("AttachmentName").Value & Chr(93) & "=" & Encoded64 'currentAttachment
            'strAttachments = strAttachments & Encoded64
           ' Debug.Print strAttachments

            rs.MoveNext
        Loop
        Debug.Print strAttachments
        GetAttachments = strAttachments
    End If

End Function

Private Function EncodeFile(text As String) As String
  Dim arrData() As Byte
  arrData = StrConv(text, vbFromUnicode)

  Dim objXML As MSXML2.DOMDocument
  Dim objNode As MSXML2.IXMLDOMElement

  Set objXML = New MSXML2.DOMDocument
  Set objNode = objXML.createElement("b64")

  objNode.DataType = "bin.base64"
  objNode.nodeTypedValue = arrData
  EncodeFile = Replace(objNode.text, vbLf, "")

  Set objNode = Nothing
  Set objXML = Nothing

End Function

Answer 1

这段代码有一些额外的代码和逻辑来附加多个附件:

Option Explicit

Sub SendEmailUsingSendGrid()
    Dim HttpReqURL As String: HttpReqURL = "https://api.sendgrid.com/api/mail.send.json"

    Const adSaveCreateNotExist = 1
    Const adSaveCreateOverWrite = 2
    Const adTypeBinary = 1
    Const adTypeText = 2
    Const adModeReadWrite = 3

    Dim YOUR_SG_CREDS_USERNAME As String
    YOUR_SG_CREDS_USERNAME = "username"

    Dim YOUR_SG_CREDS_PASSWORD As String
    YOUR_SG_CREDS_PASSWORD = "password"

    Dim multiPartUploadBoundary As String
    multiPartUploadBoundary = "123456789abc"

    Dim eTo As String
    eTo = "to@example.com"

    Dim eToName As String
    eToName = "To Name"

    Dim eSubject As String
    eSubject = "My Subject"

    Dim eBody As String
    eBody = "This is a test!"

    Dim eFrom As String
    eFrom = "from@example.com"

    Dim outputStream As Object
    Set outputStream = CreateObject("adodb.stream")
    outputStream.Type = adTypeText
    outputStream.Mode = adModeReadWrite
    outputStream.charset = "windows-1252"
    outputStream.Open

    AddParameterAndValueToStream outputStream, multiPartUploadBoundary, "api_user", YOUR_SG_CREDS_USERNAME
    AddParameterAndValueToStream outputStream, multiPartUploadBoundary, "api_key", YOUR_SG_CREDS_PASSWORD
    AddParameterAndValueToStream outputStream, multiPartUploadBoundary, "to", eTo
    AddParameterAndValueToStream outputStream, multiPartUploadBoundary, "toname", eToName
    AddParameterAndValueToStream outputStream, multiPartUploadBoundary, "subject", eSubject
    AddParameterAndValueToStream outputStream, multiPartUploadBoundary, "text", eBody
    AddParameterAndValueToStream outputStream, multiPartUploadBoundary, "from", eFrom

    Dim filesToAttach As New Collection
    filesToAttach.Add "C:\temp\test.png"
    filesToAttach.Add "C:\temp\test2.jpg"

    AddMultipleFilesToStream outputStream, multiPartUploadBoundary, filesToAttach

    outputStream.WriteText "--" + multiPartUploadBoundary + "--" + vbCrLf

    Dim binaryStream As Object
    Set binaryStream = CreateObject("ADODB.Stream")
    binaryStream.Mode = 3 'read write
    binaryStream.Type = 1 'adTypeText 'Binary
    binaryStream.Open

    ' copy text to binary stream so xmlHttp.send works correctly
    outputStream.Position = 0
    outputStream.CopyTo binaryStream
    outputStream.Close

    binaryStream.Position = 0

    Dim xmlHttp As Object
    Set xmlHttp = CreateObject("MSXML2.XMLHTTP")
    xmlHttp.Open "POST", HttpReqURL, False
    xmlHttp.setRequestHeader "Content-Type", "multipart/form-data; boundary=" + multiPartUploadBoundary
    xmlHttp.setRequestHeader "Content-Length", Len(binaryStream.Size)
    xmlHttp.send binaryStream.Read(binaryStream.Size)

    binaryStream.Close
End Sub

Sub AddParameterAndValueToStream(stream As Variant, boundary As String, paramName As String, value As String)
    stream.WriteText "--" + boundary + vbCrLf
    stream.WriteText "Content-Disposition: form-data; name=""" + paramName + """" + vbCrLf
    stream.WriteText vbCrLf
    stream.WriteText value + vbCrLf
End Sub

Sub AddFileToStream(stream As Variant, boundary As String, name As String, filePath As String)
    Dim fileBytes As String
    fileBytes = ReadBinaryFile(filePath)

    stream.WriteText "--" + boundary + vbCrLf
    stream.WriteText "Content-Disposition: form-data; name=""files[" + name + "]""; filename=""" + name + """" + vbCrLf
    stream.WriteText "Content-Type: application/octet-stream" + vbCrLf
    stream.WriteText vbCrLf
    stream.WriteText fileBytes + vbCrLf
End Sub

Sub AddMultipleFilesToStream(stream As Variant, boundary As String, filePaths As Collection)
    Dim fileCount As Integer
    fileCount = filePaths.Count

    For n = 1 To fileCount
        Dim fileName As String
        Dim filePath As String

        filePath = filePaths(n)
        fileName = Right(filePath, Len(filePath) - InStrRev(filePath, "\"))

        AddFileToStream stream, boundary, fileName, filePath
    Next n
End Sub

Function ReadBinaryFile(strPath)
    Dim oFSO: Set oFSO = CreateObject("Scripting.FileSystemObject")
    Dim oFile: Set oFile = oFSO.GetFile(strPath)

    If IsNull(oFile) Then MsgBox ("File not found: " & strPath): Exit Function

    With oFile.OpenAsTextStream()
        ReadBinaryFile = .Read(oFile.Size)
        .Close
    End With
End Function