使用 API (VBA) 的 SendGrid 附件为空或损坏
SendGrid Attachments Are Empty or Corrupt Using API (VBA)
这似乎是 SendGrid Web API 和电子邮件附件的一个常见问题。我在网络上发现了很多很多帖子，他们都遇到了同样的问题……但是 none 似乎已经找到了解决方案。 SendGrid 自己的罐头回应是使用他们的库之一......但问题仍然是当您使用没有库的语言时如何附加文件。
我已经尝试就此问题联系 SendGrid 支持人员......甚至提出支付支持费用以获得答案，但他们认为我要求的是 "code review"，但我不是。问题很简单：将附件上传到 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
请看我的"Here it is!"回答。我只是出于历史原因在这里留下这个答案。
试试这样的东西：
' Set the Server URL to the form input
HttpReqURL = "https://api.sendgrid.com/api/mail.send.json"
boundary = "----------------------------123456789abc"
Set xmlhttp = CreateObject("MSXML2.XMLHTTP")
xmlhttp.Open "POST", HttpReqURL, False
xmlhttp.setRequestHeader "Content-Type", "multipart/form-data; boundary=" + boundary
dataToSend = "--" + boundary + vbCrLf
dataToSend = dataToSend + "Content-Disposition: form-data; name=""api_user""" + vbCrLf
dataToSend = dataToSend + vbCrLf
dataToSend = dataToSend + YOUR_API_USER + vbCrLf
dataToSend = dataToSend + "--" + boundary + vbCrLf
dataToSend = dataToSend + "Content-Disposition: form-data; name=""api_key""" + vbCrLf
dataToSend = dataToSend + vbCrLf
dataToSend = dataToSend + YOUR_API_KEY + vbCrLf
dataToSend = dataToSend + "--" + boundary + vbCrLf
dataToSend = dataToSend + "Content-Disposition: form-data; name=""to""" + vbCrLf
dataToSend = dataToSend + vbCrLf
dataToSend = dataToSend + eTo + vbCrLf
dataToSend = dataToSend + "--" + boundary + vbCrLf
dataToSend = dataToSend + "Content-Disposition: form-data; name=""toname""" + vbCrLf
dataToSend = dataToSend + vbCrLf
dataToSend = dataToSend + vbCrLf
dataToSend = dataToSend + eToName + vbCrLf
dataToSend = dataToSend + "--" + boundary + vbCrLf
dataToSend = dataToSend + "Content-Disposition: form-data; name=""subject""" + vbCrLf
dataToSend = dataToSend + vbCrLf
dataToSend = dataToSend + eSubject + vbCrLf
dataToSend = dataToSend + "--" + boundary + vbCrLf
dataToSend = dataToSend + "Content-Disposition: form-data; name=""text""" + vbCrLf
dataToSend = dataToSend + vbCrLf
dataToSend = dataToSend + eBody + vbCrLf
dataToSend = dataToSend + "--" + boundary + vbCrLf
dataToSend = dataToSend + "Content-Disposition: form-data; name=""from""" + vbCrLf
dataToSend = dataToSend + vbCrLf
dataToSend = dataToSend + eFrom + vbCrLf
dataToSend = dataToSend + "--" + boundary + vbCrLf
dataToSend = dataToSend + "Content-Disposition: form-data; name=""files[1]""; filename=""myPDF.pdf""" + vbCrLf
dataToSend = dataToSend + vbCrLf
dataToSend = dataToSend + "Content-Type: application/octet-stream" + vbCrLf
dataToSend = dataToSend + vbCrLf
dataToSend = dataToSend + BASE64ENCODEDFILE + vbCrLf
dataToSend = dataToSend + "--" + boundary + "--" + vbCrLf
xmlhttp.send dataToSend
在这里！
Option Explicit
Sub SendEmailUsingSendGrid()
Dim attachmentPath As String: attachmentPath = "C:\temp\test.png"
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
AddFileToStream outputStream, multiPartUploadBoundary, "test.png", "C:\temp\test.png"
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
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
这段代码有一些额外的代码和逻辑来附加多个附件：
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
这似乎是 SendGrid Web API 和电子邮件附件的一个常见问题。我在网络上发现了很多很多帖子，他们都遇到了同样的问题……但是 none 似乎已经找到了解决方案。 SendGrid 自己的罐头回应是使用他们的库之一......但问题仍然是当您使用没有库的语言时如何附加文件。
我已经尝试就此问题联系 SendGrid 支持人员......甚至提出支付支持费用以获得答案，但他们认为我要求的是 "code review"，但我不是。问题很简单：将附件上传到 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
请看我的"Here it is!"回答。我只是出于历史原因在这里留下这个答案。
试试这样的东西：
' Set the Server URL to the form input
HttpReqURL = "https://api.sendgrid.com/api/mail.send.json"
boundary = "----------------------------123456789abc"
Set xmlhttp = CreateObject("MSXML2.XMLHTTP")
xmlhttp.Open "POST", HttpReqURL, False
xmlhttp.setRequestHeader "Content-Type", "multipart/form-data; boundary=" + boundary
dataToSend = "--" + boundary + vbCrLf
dataToSend = dataToSend + "Content-Disposition: form-data; name=""api_user""" + vbCrLf
dataToSend = dataToSend + vbCrLf
dataToSend = dataToSend + YOUR_API_USER + vbCrLf
dataToSend = dataToSend + "--" + boundary + vbCrLf
dataToSend = dataToSend + "Content-Disposition: form-data; name=""api_key""" + vbCrLf
dataToSend = dataToSend + vbCrLf
dataToSend = dataToSend + YOUR_API_KEY + vbCrLf
dataToSend = dataToSend + "--" + boundary + vbCrLf
dataToSend = dataToSend + "Content-Disposition: form-data; name=""to""" + vbCrLf
dataToSend = dataToSend + vbCrLf
dataToSend = dataToSend + eTo + vbCrLf
dataToSend = dataToSend + "--" + boundary + vbCrLf
dataToSend = dataToSend + "Content-Disposition: form-data; name=""toname""" + vbCrLf
dataToSend = dataToSend + vbCrLf
dataToSend = dataToSend + vbCrLf
dataToSend = dataToSend + eToName + vbCrLf
dataToSend = dataToSend + "--" + boundary + vbCrLf
dataToSend = dataToSend + "Content-Disposition: form-data; name=""subject""" + vbCrLf
dataToSend = dataToSend + vbCrLf
dataToSend = dataToSend + eSubject + vbCrLf
dataToSend = dataToSend + "--" + boundary + vbCrLf
dataToSend = dataToSend + "Content-Disposition: form-data; name=""text""" + vbCrLf
dataToSend = dataToSend + vbCrLf
dataToSend = dataToSend + eBody + vbCrLf
dataToSend = dataToSend + "--" + boundary + vbCrLf
dataToSend = dataToSend + "Content-Disposition: form-data; name=""from""" + vbCrLf
dataToSend = dataToSend + vbCrLf
dataToSend = dataToSend + eFrom + vbCrLf
dataToSend = dataToSend + "--" + boundary + vbCrLf
dataToSend = dataToSend + "Content-Disposition: form-data; name=""files[1]""; filename=""myPDF.pdf""" + vbCrLf
dataToSend = dataToSend + vbCrLf
dataToSend = dataToSend + "Content-Type: application/octet-stream" + vbCrLf
dataToSend = dataToSend + vbCrLf
dataToSend = dataToSend + BASE64ENCODEDFILE + vbCrLf
dataToSend = dataToSend + "--" + boundary + "--" + vbCrLf
xmlhttp.send dataToSend
在这里！
Option Explicit
Sub SendEmailUsingSendGrid()
Dim attachmentPath As String: attachmentPath = "C:\temp\test.png"
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
AddFileToStream outputStream, multiPartUploadBoundary, "test.png", "C:\temp\test.png"
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
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
这段代码有一些额外的代码和逻辑来附加多个附件：
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