Wow time is flying! Looks like my last post was in June! I built this example due to frustration. I was trying to find a way to look at and manipulate appointments in my Outlook calendar for a three month time span. The tool that I built, ultimately loaded the pulled outlook calendar items into a table. I decided not to include that part in this article as it is pretty easy.
Note: To use this example, you must add a reference to the “Microsoft Outlook XX.X Object library” the “XX.X” version will depend on the version of office suite you are using. For Microsoft Office 2013, it is version 15.0, for Office 2010, it is version 14.0.
MS Access VBA Outlook Calendar Download Example
Public Sub getCalendarData()
On Error GoTo ErrorHandler
Dim oOL As New Outlook.Application
Dim oNS As Outlook.NameSpace
Dim oAppointments As Object
Dim oAppointmentItem As Outlook.AppointmentItem
Dim strFilter As String
'Variable Inputs For Calendar Range
Dim sDate As Date 'Calendar Range Start Date
Dim eDate As Date 'Calendar Range End Date
Dim recurItem As Boolean 'Include recurring meetings true/false
'***********************
'TEST INPUT VARIABLES
'***********************
sDate = #9/1/2014# 'Set start date in range
eDate = #9/30/2014# 'Set end date in range
recurItem = True 'Include Recurring Items in calendar dump
'Set objects
Set oNS = oOL.GetNamespace("MAPI")
Set oAppointments = oNS.GetDefaultFolder(olFolderCalendar).Items
'Set filter to grab items by date range
strFilter = "[Start] >= " _
& "'" & sDate & "'" _
& " AND [End] <= " _
& "'" & eDate & "'"
'To get recurring items and work with your filter
'properly, the WITH statement must follow the order
'shown here
With oAppointments
.Sort "[Start]"
.IncludeRecurrences = recurItem
End With
'***************************
'Start Calendar Item dump loop
'***************************
For Each oAppointmentItem In oAppointments.Restrict(strFilter)
'for this demo, items will print to debug window
Debug.Print "Start: " & oAppointmentItem.Start _
& " End: " & oAppointmentItem.End _
& " Subject: " & oAppointmentItem.Subject _
& " Location: " & oAppointmentItem.Location
Next
'Garbage cleanup
Set oAppointmentItem = Nothing
Set oAppoinments = Nothing
Set oNS = Nothing
Set oOL = Nothing
Exit Sub
ErrorHandler: MsgBox "Error: " & Err & " | " & Error(Err)
'Garbage cleanup
Set oAppointmentItem = Nothing
Set oAppoinments = Nothing
Set oNS = Nothing
Set oOL = Nothing
End Sub
06/23/2015 UPDATE: Added Access DB Example. Add date range to download Outlook calendar to access table. Download
As always, I enjoy hearing about others' experiences with my examples. If you get stuck, have a question, or a suggestion, PLEASE comment.
I am new to vba and, for the life of me, I’ve been trying to figure out how to download/link the appointments into an access table with all of the fields that the traditional import tool doesn’t show (like location,start time, end time, categories). You mentioned that it was so easy you didn’t need to include it. But could you? Pretty please?
I added an example for you to download near the end of the post. Please comment if you have any questions.
This Macro is amazing !
Would it be possible to include the Shared Calendar data in the VBA Macro Code ?
Thank you Dominic! Excellent suggestion! I will update the post when I can grab some time. For a quick and dirty solution, I modified the example from: http://www.slipstick.com/developer/working-vba-nondefault-outlook-folders/
for the code on this page. Please note that the modified examples as of the time of writing this have not been tested. Please let me know if you or anyone finds a bug:
'Get Default Calendar Data (current code) ''''''''''''''''''''''''''''''''''''''''''''''''''''''' Set oAppointments = oNS.GetDefaultFolder(olFolderCalendar).Items 'Get Shared Calendar Data (at default calendar level) 'Where Shared Calendar is at the same level 'as the default calendar(such as Calendar, Inbox etc) ''''''''''''''''''''''''''''''''''''''''''''''''''''''' Set oAppointments = oNS.GetDefaultFolder(olFolderCalendar).Parent.Folders("SharedCalName").Items 'Get Shared Calendar Data (when subfolder of default folders) 'when folder is a sub folder of the default level '(under default level of Calendar, Inbox etc) ''''''''''''''''''''''''''''''''''''''''''''''''''''''' Set oAppointments = oNS.GetDefaultFolder(olFolderCalendar).Folders("SharedCalName").ItemsHello Ryan, I have been looking for a solution or example code to get Outlook Calendar items with detail pulled into Access. I just found this web page but unfortunately, the download link results in an error. Is there any way you could be kind enough to send it to me?
Thanks very much
Chris
Hi Ryan, I have no idea if you are still monitoring this, but thank you so much for creating the download!!! It works wonderfully! However, I tried to add additional fields (e.g., Notes) to the VBA script in the function module and… I couldn’t get it to work. Eventually, I would like to add customized fields to my Outlook Appointment (separate issue, I know) and have those fields import into Access as well using your module. Thanks again!
Erika
Hi Ryan,
Thanks for sharing the knowledge. Hope you can give me a hand.
I’ve been exporting room calendars from Outlook for a while now, helps me calculate room usage rate and occupancy rate and has been invaluable to show that many rooms are heavily underutilized, thus helping plan space better. I do all these things with pivot charts.
I can only export one room at a time though. I started by going to “Open Calendar” “From Room List” and adding every room in the company, this will get a new “folder” on the left pane called “Rooms” I enable one at a time, and run the Macro, but the Macro will only export the active calendar, so if I own calendar is selected (bolder font) then my own calendar is exported, so i have to make sure the room’s calendar is selected or “active”.
Now they are asking me to make this reports bigger and more often, so i want a more automated way to simply export as many calendar as I want, whether into the same workbook with different sheets, or different workbooks, or same workbook same sheet.
Hope you can help me.
Thanks!
Sub ExportAppointmentsToExcel()
Const SCRIPT_NAME = “Export Outlook’s Active Calendar to Excel”
Const xlAscending = 1
Const xlYes = 1
Dim olkFld As Object, _
olkLst As Object, _
olkRes As Object, _
olkApt As Object, _
olkRec As Object, _
excApp As Object, _
excWkb As Object, _
excWks As Object, _
lngRow As Long, _
lngCnt As Long, _
strFil As String, _
strLst As String, _
strDat As String, _
datBeg As Date, _
datEnd As Date, _
arrTmp As Variant
Set olkFld = Outlook.ActiveExplorer.CurrentFolder
If olkFld.DefaultItemType = olAppointmentItem Then
strDat = InputBox(“Enter the date range of the appointments to export in the form “”mm/dd/yyyy to mm/dd/yyyy”””, SCRIPT_NAME, Date & ” to ” & Date)
arrTmp = Split(strDat, “to”)
datBeg = IIf(IsDate(arrTmp(0)), arrTmp(0), Date) & ” 12:00am”
datEnd = IIf(IsDate(arrTmp(1)), arrTmp(1), Date) & ” 11:59pm”
strFil = InputBox(“Enter a filename (including path) to save the exported appointments to.”, SCRIPT_NAME, “c:\temp\”)
If strFil “” Then
Set excApp = CreateObject(“Excel.Application”)
Set excWkb = excApp.Workbooks.Add()
Set excWks = excWkb.Worksheets(1)
‘Write Excel Column Headers
With excWks
.Cells(1, 1) = “Meeting Room”
.Cells(1, 2) = “Meeting Organizer”
.Cells(1, 3) = “Meeting Participants”
.Cells(1, 4) = “Meeting Start time”
.Cells(1, 5) = “Meeting Duration minutes”
.Cells(1, 6) = “Is meeting recurring?”
End With
lngRow = 2
Set olkLst = olkFld.Items
olkLst.Sort “[Start]”
olkLst.IncludeRecurrences = True
Set olkRes = olkLst.Restrict(“[Start] >= ‘” & Format(datBeg, “ddddd h:nn AMPM”) & “‘ AND [Start] <= '" & Format(datEnd, "ddddd h:nn AMPM") & "'")
'Write appointments to spreadsheet
For Each olkApt In olkRes
'Only export appointments
If olkApt.Class = olAppointment Then
strLst = ""
For Each olkRec In olkApt.Recipients
strLst = strLst & olkRec.Name & ", "
Next
If strLst “” Then strLst = Left(strLst, Len(strLst) – 2)
‘A row for each field to export
excWks.Cells(lngRow, 1) = olkApt.Location
excWks.Cells(lngRow, 2) = olkApt.Organizer
excWks.Cells(lngRow, 3) = olkApt.Recipients.Count
excWks.Cells(lngRow, 4) = olkApt.Start
excWks.Cells(lngRow, 5) = olkApt.Duration
excWks.Cells(lngRow, 6) = olkApt.IsRecurring
lngRow = lngRow + 1
lngCnt = lngCnt + 1
End If
Next
excWks.Columns(“A:G”).AutoFit
excWkb.SaveAs strFil
excWkb.Close
MsgBox “Process complete. A total of ” & lngCnt & ” appointments were exported.”, vbInformation + vbOKOnly, SCRIPT_NAME
End If
Else
MsgBox “Operation cancelled. The selected folder is not a calendar. You must select a calendar for this macro to work.”, vbCritical + vbOKOnly, SCRIPT_NAME
End If
Set excWks = Nothing
Set excWkb = Nothing
Set excApp = Nothing
Set olkApt = Nothing
Set olkLst = Nothing
Set olkFld = Nothing
End Sub