SendGrid Attachments Are Empty or Corrupt Using API (VBA)

Question

This seems to be a constant issue with the SendGrid Web API and emailing attachments. I\'ve found many, many posts across the web all of whom are having this same issue... but n

Answer 1

Here it is!

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