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)
The Code
Now, since we have all the framework already created (see the above video), it really becomes as simple as creating a single function.
Enum EventImportance
EventHighImportance = 1
EventNormalImportance = 2
EventLowImportance = 3
End Enum
'---------------------------------------------------------------------------------------
' Procedure : Outlook_Calendar_CreateEvent
' Author : Daniel Pineault, CARDA Consultants Inc.
' Website : http://www.cardaconsultants.com
' Purpose : Use the Microsoft Graph REST API to create an event in the user's calendar
' 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: None required
' References:
' Request
' https://learn.microsoft.com/en-us/graph/api/user-post-events?view=graph-rest-1.0&tabs=http
' Properties
' https://learn.microsoft.com/en-us/graph/api/resources/event?view=graph-rest-1.0
' Time Zones
' https://learn.microsoft.com/en-us/windows-hardware/manufacture/desktop/default-time-zones?view=windows-11
'
' Input Variables:
' ~~~~~~~~~~~~~~~~
'
'
' Usage:
' ~~~~~~
' Outlook_Calendar_CreateEvent("")
' Returns -> True/False
'
' Revision History:
' Rev Date(yyyy-mm-dd) Description
' **************************************************************************************
' 1 2024-05-08
'---------------------------------------------------------------------------------------
Public Function Outlook_Calendar_CreateEvent(ByVal sSubject As String, _
ByVal sBody As String, _
ByVal dtStart As Date, _
ByVal dtEnd As Date, _
ByVal sTimeZone As String, _
Optional bIsAllDay As Boolean = False, _
Optional lReminderMinsBefore As Long = 0, _
Optional sRequiredAttendees As String, _
Optional sOptionalAttendees As String, _
Optional sLocationName As String, _
Optional sLocationAddress As String, _
Optional lEventImportance As EventImportance = EventNormalImportance) As Boolean
Dim sContentType As String
Dim sURL As String
Dim sHTTPRequest As String
Dim sImportance As String
Dim sEmailContentType As String
Dim aAttendees() As String
Dim aLocationAddress() As String
Dim iCounter As Long
Dim sEventImportance As String
Dim sStart As String
Dim sEnd As String
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/events"
'Basic Information
sHTTPRequest = "{ " & vbCrLf & _
" ""createdDateTime"": """ & Format(SC_GetUTCComponent(Now), "yyyy-mm-ddThh:nn:ssZ") & """, " & vbCrLf & _
" ""subject"": """ & JS_JSON_EscapeString(sSubject) & """, " & vbCrLf & _
" ""body"": { " & vbCrLf & _
" ""contentType"": ""HTML"", " & vbCrLf & _
" ""content"": """ & JS_JSON_EscapeString(sBody) & """ " & vbCrLf & _
" }, " & vbCrLf
'Dates
If bIsAllDay Then
'If DateDiff("d", dtStart, dtEnd) = 0 Then dtEnd = DateAdd("d", 1, dtEnd)
dtEnd = DateAdd("d", 1, dtEnd) 'push to the next midnight
sStart = Format(dtStart, "yyyy-mm-ddT00:00:00")
sEnd = Format(dtEnd, "yyyy-mm-ddT00:00:00")
Else
sStart = Format(dtStart, "yyyy-mm-ddThh:nn:ss")
sEnd = Format(dtEnd, "yyyy-mm-ddThh:nn:ss")
End If
sHTTPRequest = sHTTPRequest & _
" ""start"": { " & vbCrLf & _
" ""dateTime"": """ & sStart & """, " & vbCrLf & _
" ""timeZone"": """ & sTimeZone & """ " & vbCrLf & _
" }, " & vbCrLf & _
" ""end"": { " & vbCrLf & _
" ""dateTime"": """ & sEnd & """, " & vbCrLf & _
" ""timeZone"": """ & sTimeZone & """ " & vbCrLf & _
" }, " & vbCrLf & _
" ""isAllDay"": " & IIf(bIsAllDay, "true", "false") & ","
'Reminder in Minutes before the event, 0=>@ the time of the event, 1440=>1 day prior, ...
If lReminderMinsBefore > 0 Then
sHTTPRequest = sHTTPRequest & " ""isReminderOn"": true ," & vbCrLf
sHTTPRequest = sHTTPRequest & " ""reminderMinutesBeforeStart"": " & lReminderMinsBefore & " ," & vbCrLf
Else
sHTTPRequest = sHTTPRequest & " ""isReminderOn"": false ," & vbCrLf
End If
'Location
If sLocationName <> "" Then
sHTTPRequest = sHTTPRequest & _
" ""location"":{ " & vbCrLf & _
" ""displayName"":""" & sLocationName & """, " & vbCrLf
If sLocationAddress <> "" Then
aLocationAddress = Split(sLocationAddress, ",")
sHTTPRequest = sHTTPRequest & _
" ""address"":{" & vbCrLf & _
" ""street"": """ & aLocationAddress(0) & """," & vbCrLf & _
" ""city"": """ & aLocationAddress(1) & """," & vbCrLf & _
" ""state"": """ & aLocationAddress(2) & """," & vbCrLf & _
" ""countryOrRegion"": """ & aLocationAddress(3) & """," & vbCrLf & _
" ""postalCode"": """ & aLocationAddress(4) & """," & vbCrLf & _
" }, " & vbCrLf
End If
sHTTPRequest = sHTTPRequest & _
" }, " & vbCrLf
End If
'Attendees
If sRequiredAttendees <> "" Or sOptionalAttendees <> "" Then
sHTTPRequest = sHTTPRequest & _
" ""attendees"": [ " & vbCrLf
'Required Attendees
If sRequiredAttendees <> "" Then
If Right(sRequiredAttendees, 1) = ";" Then sRequiredAttendees = Left(sRequiredAttendees, Len(sRequiredAttendees) - 1)
aAttendees = Split(sRequiredAttendees, ";")
For iCounter = 0 To UBound(aAttendees)
sHTTPRequest = sHTTPRequest & _
" { " & vbCrLf & _
" ""emailAddress"": { " & vbCrLf & _
" ""address"":""" & aAttendees(iCounter) & """, " & vbCrLf & _
" }, " & vbCrLf & _
" ""type"": ""required"" " & vbCrLf & _
" }, " & vbCrLf
Next iCounter
End If
'Optional Attendees
If sOptionalAttendees <> "" Then
If Right(sOptionalAttendees, 1) = ";" Then sOptionalAttendees = Left(sOptionalAttendees, Len(sOptionalAttendees) - 1)
aAttendees = Split(sOptionalAttendees, ";")
For iCounter = 0 To UBound(aAttendees)
sHTTPRequest = sHTTPRequest & _
" { " & vbCrLf & _
" ""emailAddress"": { " & vbCrLf & _
" ""address"":""" & aAttendees(iCounter) & """, " & vbCrLf & _
" }, " & vbCrLf & _
" ""type"": ""optional"" " & vbCrLf & _
" }, " & vbCrLf
Next iCounter
End If
sHTTPRequest = sHTTPRequest & _
" ], " & vbCrLf
End If
Select Case lEventImportance
Case 1
sEventImportance = "high"
Case 2
sEventImportance = "normal"
Case 3
sEventImportance = "low"
End Select
sHTTPRequest = sHTTPRequest & _
" ""allowNewTimeProposals"": true, " & vbCrLf & _
" ""importance"": """ & sEventImportance & """, " & vbCrLf & _
"}"
sHTTPRequest = Replace(sHTTPRequest, vbCrLf, "")
Call HTTP_SendRequest(sURL, , sContentType, sHTTPRequest, True)
If lHTTP_Status = 201 Or lHTTP_Status = 202 Then
Outlook_Calendar_CreateEvent = True
End If
End Function
Usage Example
Below would be an example of how you might call it in your application:
Outlook_Calendar_CreateEvent("Graph REST API Meeting", "Let's discuss what we can do with the REST API!", #5/8/2024 20:00#, #5/8/2024 22:15#, "Eastern Standard Time", ,30, , ,"Empire State Building", "20 West 34th Street,New York,New York,USA,10001", EventHighImportance)
or
Outlook_Calendar_CreateEvent("Graph REST API Meeting", "Let's discuss what we can do with the REST API!", #5/8/2024 20:00#, #5/8/2024 22:15#, "Eastern Standard Time", ,30,"someone@domain1.com;someoneelse@domain2.com", ,"Conference Room")
Don’t Forget About Those Pesky Permissions
For this to work, you must first add the necessary Calendar API Permission(s). For my testing I added the “calendars.readwrite” API. If you don’t, you are likely to get a server response such as:
403
{“error”:
{
“code”:”ErrorAccessDenied”,
“message”:”Access is denied. Check credentials and try again.”
}
}Microsoft Graph REST API
{“error”:
{
“code”:”ErrorAccessDenied”,
“message”:”Access is denied. Check credentials and try again.”
}
}Microsoft Graph REST API
And don’t forget, once you make the change via entra, you also need to update that value in your Authentication Scope variable!