I just wanted to share a great solution I’ve recently developed in Emailing from Microsoft Access. When I was researching email methods from Access a thought occurred to me that there should be an A.P.I. that would do this the easy way. In fact there are several available… but none that I could find provided VBA code examples (which didn’t surprise me).
All of them did have a web A.P.I. which was all I needed to translate a web request from the other language examples given. In the End I ended up taking Eli the Computer Guy’s recommendation and used the SendGrid API. I’ve found that SendGrid seems to have 24/7 online support which is great for contractors like me who seem to burn the late night hours.
IMPORTANT NOTE: This script has been changed due to SendGrid API changes which broke the former attachment functionality. Justin Steele provided the key to fixing the attachment issues. The solution shown below is my own implementation with her provided attachment fix:
All of them did have a web A.P.I. which was all I needed to translate a web request from the other language examples given. In the End I ended up taking Eli the Computer Guy’s recommendation and used the SendGrid API. I’ve found that SendGrid seems to have 24/7 online support which is great for contractors like me who seem to burn the late night hours.
IMPORTANT NOTE: This script has been changed due to SendGrid API changes which broke the former attachment functionality. Justin Steele provided the key to fixing the attachment issues. The solution shown below is my own implementation with her provided attachment fix:
Code:
Sub SendEmail()
Dim HttpReqURL As String
Dim eUser As String
Dim ePass As String
Dim eTo As String
Dim eToName As String
Dim eSubject As String
Dim eBody As String
Dim eFrom As String
Dim multiPartBoundary As String
Dim outputStream As Object
Dim binaryStream As Object
Dim rs As DAO.Recordset
Dim SQL As String
Const adSaveCreateNotExist = 1
Const adSaveCreateOverWrite = 2
Const adTypeBinary = 1
Const adTypeText = 2
Const adModeReadWrite = 3
multiPartBoundary = "123456789abc"
HttpReqURL = "https://api.sendgrid.com/api/mail.send.json"
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 outputStream = CreateObject("adodb.stream")
outputStream.Type = adTypeText
outputStream.Mode = adModeReadWrite
outputStream.Charset = "windows-1252"
outputStream.Open
AddStreamParam outputStream, multiPartBoundary, "api_user", eUser
AddStreamParam outputStream, multiPartBoundary, "api_key", ePass
AddStreamParam outputStream, multiPartBoundary, "to", eTo
AddStreamParam outputStream, multiPartBoundary, "toname", eToName
AddStreamParam outputStream, multiPartBoundary, "subject", eSubject
AddStreamParam outputStream, multiPartBoundary, "text", eBody
AddStreamParam outputStream, multiPartBoundary, "from", eFrom
' Add Attachments
AddAttachmentsToStream outputStream, multiPartBoundary
outputStream.WriteText "--" + multiPartBoundary + "--" + vbCrLf
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=" + multiPartBoundary
xmlHttp.setRequestHeader "Content-Length", Len(binaryStream.Size)
xmlHttp.send binaryStream.Read(binaryStream.Size)
binaryStream.Close
rs.MoveNext
Loop
End If
Set rs = Nothing
End Sub
Sub AddStreamParam(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 AddAttachmentsToStream(stream As Variant, boundary As String)
Dim rs As DAO.Recordset
Dim rsAttach As DAO.Recordset
Dim SQL As String
Dim currentAttachment As String
Dim strAttachments As String
Dim fileName As String
SQL = "SELECT * FROM tblMessageAttachments WHERE [MessageID] = " & MessageID
Set rsAttach = CurrentDb.OpenRecordset(SQL, dbOpenDynaset, dbSeeChanges)
If Not (rsAttach.EOF And rsAttach.BOF) Then
rsAttach.MoveFirst
Do Until rsAttach.EOF = True
' Set Current Attachment
fileName = rsAttach.Fields("AttachmentName").value
currentAttachment = rsAttach.Fields("AttachmentLocation").value & fileName
'Debug.Print currentAttachment
' Add Attachement to outputStream
AddFileToStream stream, boundary, fileName, currentAttachment
rsAttach.MoveNext
Loop
End If
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
Last edited:
