So, a few weeks ago I published articles and videos of how we can implement Microsoft’s Graph API so we could send e-mails:
How-to Send E-mails Via Outlook Using The Microsoft Graph API
Well, unless you’ve been living under a rock, by now, you are aware of some fundamental changes coming to Outlook in the not too distant future, mainly the fact that it will cease to support any form of VBA! Now, many have tried to make Microsoft reverse course, understand the millions of solutions (Access, Word, Excel, …) that will instantaneously break with such a switch, but there has been no change in course. Actually, per the usual, there has been little to no response whatsoever. This brings us to today’s post!
creates calendar events:
Use The Microsoft Graph REST API To Create An Event In The User's Calendar
So after my recent YouTube video on sending an e-mail via an Outlook.com account using the Microsoft Graph REST API: I thought I’d provide a function which can be used to create an event in the user’s calendar. (it is still a work in progress though)
That said, my first article, about sending e-mails, was a first stab into this matter and I had left it somewhat incomplete, that is that I never provided for including attachments with the e-mail.
So, today, I wish to correct that shortcoming.
The New E-mail Procedure
So, let’s just dive in and let me present the final result:
'---------------------------------------------------------------------------------------
' Procedure : Outlook_Email
' Author : Daniel Pineault, CARDA Consultants Inc.
' Website : http://www.cardaconsultants.com
' Purpose : Send e-mails via your Outlook account using the Graph API
' Copyright : The following is release as Attribution-ShareAlike 4.0 International
' (CC BY-SA 4.0) - https://creativecommons.org/licenses/by-sa/4.0/
' Req'd Refs: Late Binding -> none required
' Dependencies:
' EmailContentType Enum
' EmailImportance Enum
' Demo File from
' https://www.devhut.net/how-to-send-e-mails-via-outlook-using-the-microsoft-graph-api/
'
' Input Variables:
' ~~~~~~~~~~~~~~~~
' sTo : To Recipient email address string (semi-colon separated list)
' sSubject : Text string (HTML) to be used as the email subject line
' sMessage : Text string to be used as the email body (actual message)
' sCC : CC Recipient email address string (semi-colon separated list)
' sBCC : BCC Recipient email address string (semi-colon separated list)
' vAttachments : Array of attachment (complete file paths with
' filename and extensions)
' lImportance : E-mail importance (Low, Normal, Medium)
' lEmailContentType : Content Type (Text, HTML)
' bSaveInSentFolder : Should the e-mail be save to your Sent Folder, or not
'
' Usage:
' ~~~~~~
' Simple e-mail
' Outlook_Email("someone@somewhere.com", "Subject", "Here is an e-mail.")
'
' HTML e-mail
' Outlook_Email("someone@somewhere.com", "Subject", "Here is an e-mail.")
'
' E-mail with attachments
' Outlook_Email("someone@somewhere.com", "Subject", "Here is an e-mail.", , , _
' array("C:\Temp\ECR20566.pdf", "C:\Users\Dev\Desktop\ProjectAnalysis.xlsx"))
'
' Revision History:
' Rev Date(yyyy-mm-dd) Description
' **************************************************************************************
' ... 2024-03-08
' 1 2024-04-21 Initial Release
'---------------------------------------------------------------------------------------
Public Function Outlook_Email(ByVal sTo As String, _
ByVal sSubject As String, _
ByVal sMessage As String, _
Optional sCC As String, _
Optional sBCC As String, _
Optional vAttachments As Variant, _
Optional lImportance As EmailImportance = NormalImportance, _
Optional lEmailContentType As EmailContentType = HTML, _
Optional bSaveInSentFolder As Boolean = True) As Boolean
'https://learn.microsoft.com/en-us/graph/api/user-post-messages?view=graph-rest-1.0&tabs=http
'https://learn.microsoft.com/en-us/graph/api/user-sendmail?view=graph-rest-1.0&tabs=http
'https://learn.microsoft.com/en-us/graph/api/resources/message?view=graph-rest-1.0
Dim sContentType As String
Dim sURL As String
Dim sHTTPRequest As String
Dim sImportance As String
Dim sEmailContentType As String
Dim i As Long
If OAuth2.access_token = "" Then OAuth2_StoredCredentials_Load 'Make sure we have credential before proceeding
If OAuth2_CheckToken = False Then DoCmd.OpenForm sAuthenticationForm, , , , , acDialog 'Force authentication if req'd
sContentType = "application/json"
sURL = "https://graph.microsoft.com/v1.0/me/sendMail"
Select Case lImportance
Case 1
sImportance = "high"
Case 2
sImportance = "normal"
Case 3
sImportance = "low"
End Select
Select Case lEmailContentType
Case 1
sEmailContentType = "HTML"
Case 2
sEmailContentType = "Text"
End Select
sHTTPRequest = "{" & vbCrLf & _
"""message"":{" & vbCrLf & _
"""subject"":""" & sSubject & """," & vbCrLf & _
"""importance"":""" & sImportance & """," & vbCrLf & _
"""body"":{" & vbCrLf & _
"""contentType"": """ & sEmailContentType & """," & vbCrLf & _
"""content"": """ & JS_JSON_EscapeString(sMessage) & """" & vbCrLf & _
"}," & vbCrLf & _
"""toRecipients"":[" & vbCrLf & _
"{" & vbCrLf & _
"""emailAddress"":{" & vbCrLf & _
"""address"":""" & sTo & """" & vbCrLf & _
"}" & vbCrLf & _
"}" & vbCrLf & _
"]" & vbCrLf
If sCC <> "" Then
sHTTPRequest = sHTTPRequest & ",""ccRecipients"": [ " & vbCrLf & _
" { " & vbCrLf & _
" ""emailAddress"": { " & vbCrLf & _
" ""address"": """ & sCC & """ " & vbCrLf & _
" } " & vbCrLf & _
" } " & vbCrLf & _
" ]"
End If
If sBCC <> "" Then
sHTTPRequest = sHTTPRequest & ",""bccRecipients"": [ " & vbCrLf & _
" { " & vbCrLf & _
" ""emailAddress"": { " & vbCrLf & _
" ""address"": """ & sBCC & """ " & vbCrLf & _
" } " & vbCrLf & _
" } " & vbCrLf & _
" ]"
End If
If Not IsMissing(vAttachments) Then
sHTTPRequest = sHTTPRequest & ",""attachments"": [ " & vbCrLf
If IsArray(vAttachments) Then
For i = LBound(vAttachments) To UBound(vAttachments)
If vAttachments(i) <> "" And vAttachments(i) <> "False" Then
sHTTPRequest = sHTTPRequest & " { " & vbCrLf & _
" ""@odata.type"": ""#microsoft.graph.fileAttachment""," & vbCrLf & _
" ""name"": """ & GetFileName(vAttachments(i)) & """, " & vbCrLf & _
" ""contentBytes"": """ & EncodeFileBase64(ReadFileAsBinary(vAttachments(i))) & """, " & vbCrLf & _
" },"
End If
Next i
Else
If vAttachments <> "" Then
sHTTPRequest = sHTTPRequest & " { " & vbCrLf & _
" ""@odata.type"": ""#microsoft.graph.fileAttachment""," & vbCrLf & _
" ""name"": """ & GetFileName(vAttachments) & """, " & vbCrLf & _
" ""contentBytes"": """ & EncodeFileBase64(ReadFileAsBinary(vAttachments)) & """, " & vbCrLf & _
" } "
End If
End If
sHTTPRequest = sHTTPRequest & " ]"
End If
sHTTPRequest = sHTTPRequest & "}," & vbCrLf & _
"""saveToSentItems"":" & IIf(bSaveInSentFolder, "true", "false") & "" & vbCrLf & _
"}"
sHTTPRequest = Replace(sHTTPRequest, vbCrLf, "")
Call HTTP_SendRequest(sURL, , sContentType, sHTTPRequest, True)
If lHTTP_Status = 200 Or lHTTP_Status = 202 Then
Outlook_Email = True
Else
Debug.Print sHTTPRequest
Debug.Print "--------"
Debug.Print sHTTP_ResponseText
End If
End Function
As always, because of everything involved in making HTTP requests, oAuth authentication … first you need to download the demo file from my original article as it has all the required framework to make the above work!
How-to Send E-mails Via Outlook Using The Microsoft Graph API
Well, unless you’ve been living under a rock, by now, you are aware of some fundamental changes coming to Outlook in the not too distant future, mainly the fact that it will cease to support any form of VBA! Now, many have tried to make Microsoft reverse course, understand the millions of solutions (Access, Word, Excel, …) that will instantaneously break with such a switch, but there has been no change in course. Actually, per the usual, there has been little to no response whatsoever. This brings us to today’s post!
Usage Example(s)
Now, it truly is simple to use!
Text E-mail
Call Outlook_Email("someone@somewhere.com", "Subject", "Here is an e-mail.")
HTML E-mail
Outlook_Email("someone@somewhere.com", "Subject", "Here is an e-mail.")
Single Attachment
Outlook_Email("someone@somewhere.com", "Subject", "Here is an e-mail.", , , "C:\Temp\ECR20566.pdf")
Multiple Attachment
Outlook_Email("someone@somewhere.com", "Subject", "Here is an e-mail.", , , array("C:\Temp\ECR20566.pdf", "C:\Users\Dev\Desktop\ProjectAnalysis.xlsx"))
Required Helper Functions
Now, to be able to include attachments we need to base64 encode them. For this we can simply grab the functions created when I was doing similar work with Thunderbird!
VBA - Thunderbird Automation With Embedded Images
Like I have done previously with Outlook Automation, I wanted to explorer the possibilities of embedding images in Thunderbird via VBA Automation
'---------------------------------------------------------------------------------------
' Procedure : ReadFileAsBinary
' Author : Daniel Pineault, CARDA Consultants Inc.
' Website : http://www.cardaconsultants.com
' Purpose : Reads a file as binary content
' Copyright : The following is release as Attribution-ShareAlike 4.0 International
' (CC BY-SA 4.0) - https://creativecommons.org/licenses/by-sa/4.0/
' Req'd Refs: Late Binding -> None required
' Early Binding -> Microsoft ActiveX Data Objects X.X Library
'
' Input Variables:
' ~~~~~~~~~~~~~~~~
' sFile : Fully qualified path and filename of the file to read
'
' Revision History:
' Rev Date(yyyy-mm-dd) Description
' **************************************************************************************
' 1 2022-10-05 Initial Public Release
'---------------------------------------------------------------------------------------
Public Function ReadFileAsBinary(ByVal sFile As String) As Variant
On Error GoTo Error_Handler
'#Const EarlyBind = 1 'Use Early Binding
#Const EarlyBind = 0 'Use Late Binding
#If EarlyBind Then
Dim oADOStream As ADODB.Stream
#Else
Dim oADOStream As Object
Const adTypeBinary = 1
#End If
Dim fileBytes() As Byte
#If EarlyBind Then
Set oADOStream = New ADODB.Stream
#Else
Set oADOStream = CreateObject("ADODB.Stream")
#End If
With oADOStream
.Open
.Type = adTypeBinary
.LoadFromFile sFile
fileBytes() = .Read
.Close
End With
ReadFileAsBinary = fileBytes()
Error_Handler_Exit:
On Error Resume Next
If Not oADOStream Is Nothing Then
oADOStream.Close
Set oADOStream = Nothing
End If
Exit Function
Error_Handler:
MsgBox "The following error has occured" & vbCrLf & vbCrLf & _
"Error Source: ReadFileAsBinary" & vbCrLf & _
"Error Number: " & Err.Number & vbCrLf & _
"Error Description: " & Err.Description & _
Switch(Erl = 0, "", Erl <> 0, vbCrLf & "Line No: " & Erl) _
, vbOKOnly + vbCritical, "An Error has Occured!"
Resume Error_Handler_Exit
End Function
and
'---------------------------------------------------------------------------------------
' Procedure : EncodeFileBase64
' Author : Daniel Pineault, CARDA Consultants Inc.
' Website : http://www.cardaconsultants.com
' Purpose : Encodes the supplied byte array as a base64 string used for HTML img tags
' Copyright : The following is release as Attribution-ShareAlike 4.0 International
' (CC BY-SA 4.0) - https://creativecommons.org/licenses/by-sa/4.0/
' Req'd Refs: Late Binding -> None required
' Early Binding -> Microsoft XML, v6.0
'
' Input Variables:
' ~~~~~~~~~~~~~~~~
' fileBytes : binary byte array of the file to convert to base64
'
' Usage:
' ~~~~~~
' sB64 = EncodeFileBase64(ReadFileAsBinary("C:\Temp\OrgChart.jpg"))
'
' Revision History:
' Rev Date(yyyy-mm-dd) Description
' **************************************************************************************
' 1 2022-10-05 Initial Public Release
'---------------------------------------------------------------------------------------
Public Function EncodeFileBase64(fileBytes() As Byte) As String
On Error GoTo Error_Handler
'#Const EarlyBind = 1 'Use Early Binding
'#Const EarlyBind = 0 'Use Late Binding
#If EarlyBind Then
Dim oXML As MSXML2.DOMDocument60
Dim oNode As MSXML2.IXMLDOMElement
Set oXML = New MSXML2.DOMDocument60
#Else
Dim oXML As Object
Dim oNode As Object
Set oXML = CreateObject("MSXML2.DOMDocument.6.0")
#End If
Set oNode = oXML.createElement("b64")
With oNode
.DataType = "bin.base64"
.nodeTypedValue = fileBytes
EncodeFileBase64 = Replace(.text, vbLf, "")
End With
Error_Handler_Exit:
On Error Resume Next
If Not oNode Is Nothing Then Set oNode = Nothing
If Not oXML Is Nothing Then Set oXML = Nothing
Exit Function
Error_Handler:
MsgBox "The following error has occured" & vbCrLf & vbCrLf & _
"Error Source: EncodeFileBase64" & vbCrLf & _
"Error Number: " & Err.Number & vbCrLf & _
"Error Description: " & Err.Description & _
Switch(Erl = 0, "", Erl <> 0, vbCrLf & "Line No: " & Erl) _
, vbOKOnly + vbCritical, "An Error has Occured!"
Resume Error_Handler_Exit
End Function
Lastly, I use a simple function to extract the filename from the full path
'---------------------------------------------------------------------------------------
' Procedure : GetFileName
' Author : CARDA Consultants Inc.
' Website : http://www.cardaconsultants.com
' Purpose : Return the filename from a path\filename input
' Copyright : The following may be altered and reused as you wish so long as the
' copyright notice is left unchanged (including Author, Website and
' Copyright). It may not be sold/resold or reposted on other sites (links
' back to this site are allowed).
'
' Input Variables:
' ~~~~~~~~~~~~~~~~
' sFile - string of a path and filename (ie: "c:\temp\test.xls")
'
' Revision History:
' Rev Date(yyyy/mm/dd) Description
' **************************************************************************************
' 1 2008-02-06 Initial Release
'---------------------------------------------------------------------------------------
Function GetFileName(ByVal sFile As String)
On Error GoTo Err_Handler
GetFileName = Right(sFile, Len(sFile) - InStrRev(sFile, "\"))
Exit_Err_Handler:
Exit Function
Err_Handler:
MsgBox "The following error has occurred" & vbCrLf & vbCrLf & _
"Error Number: " & Err.Number & vbCrLf & _
"Error Source: GetFileName" & vbCrLf & _
"Error Description: " & Err.Description, vbCritical, "An Error has Occurred!"
GoTo Exit_Err_Handler
End Function
and there you have it, attachments with the Graph API.