Extract Calendar data from Outlook into Excel

August 10, 2008 – 9:15 am by JP

I completed some VBA code that will allow you to export appointment information (meetings, appointments) from Outlook into Excel. It requires a reference to the Outlook object library (unless you care to reengineer it), but it works even with Outlook closed. I think you'll find it very useful for when you need to examine or manipulate Outlook Calendar data, and want something a bit faster (and more flexible) than Outlook's built-in exporter.

The code begins by setting a reference to the Outlook Application object, which, depending on whether Outlook is open or not, can take up to 10 seconds, so I strongly recommend you have Outlook open when you run this code. Then we reference the default Calendar folder and filter out the items based on dates passed as arguments to the sub.

Because recurring appointments can potentially have an unlimited number of recurrences (when the organizer does not specify an End Date), we use the Restrict method to limit the number of calendar entries we need to return to only those that fall between 12 AM on the start date and 11:59 PM on the end date.

Be careful with the Restrict method, however; if you use it in an Exchange environment, it can slow down Outlook's performance.

plain text version

VBA:

Private Sub GetCalData(StartDate As Date, Optional EndDate As Date)
' -------------------------------------------------
' Notes:
' If Outlook is not open, it still works, but much slower (~8 secs vs. 2 secs w/ Outlook open).
' Make sure to reference the Outlook object library before running the code
' End Date is optional, if you want to pull from only one day, use: Call GetCalData("7/14/2008")
' -------------------------------------------------
Dim olApp As Outlook.Application
Dim olNS As Outlook.Namespace
Dim myCalItems As Outlook.Items
Dim ItemstoCheck As Outlook.Items
Dim ThisAppt As Outlook.AppointmentItem
Dim MyItem As Object
Dim StringToCheck As String
Dim MyBook As Excel.Workbook
Dim rngStart As Excel.Range
Dim i As Long
Dim NextRow As Long
' if no end date was specified, then the requestor only wants one day, so set EndDate = StartDate
' this will let us return appts from multiple dates, if the requestor does in fact set an appropriate end date
If EndDate = "12:00:00 AM" Then
EndDate = StartDate
End If
If EndDate <StartDate Then
MsgBox "Those dates seem switched, please check them and try again.", vbInformation
GoTo ExitProc
End If
If EndDate - StartDate> 28 Then
' ask if the requestor wants so much info
If MsgBox("This could take some time. Continue anyway?", vbInformation + vbYesNo) = vbNo Then
GoTo ExitProc
End If
End If
' get or create Outlook object and make sure it exists before continuing
On Error Resume Next
Set olApp = GetObject(, "Outlook.Application")
If Err.Number <> 0 Then
Set olApp = CreateObject("Outlook.Application")
End If
On Error GoTo 0
If olApp Is Nothing Then
MsgBox "Cannot start Outlook.", vbExclamation
GoTo ExitProc
End If
Set olNS = olApp.GetNamespace("MAPI")
Set myCalItems = olNS.GetDefaultFolder(olFolderCalendar).Items
' ------------------------------------------------------------------
' the following code adapted from:
' http://www.outlookcode.com/article.aspx?id=30
'
With myCalItems
.Sort "[Start]", False
.IncludeRecurrences = True
End With
'
StringToCheck = "[Start]>= " & Quote(StartDate & " 12:00 AM") & " AND [End] <= " & _
Quote(EndDate & " 11:59 PM")
Debug.Print StringToCheck
'
Set ItemstoCheck = myCalItems.Restrict(StringToCheck)
Debug.Print ItemstoCheck.Count
' ------------------------------------------------------------------
If ItemstoCheck.Count> 0 Then
' we found at least one appt
' check if there are actually any items in the collection, otherwise exit
If ItemstoCheck.Item(1) Is Nothing Then GoTo ExitProc
Set MyBook = Excel.Workbooks.Add
Set rngStart = MyBook.Sheets(1).Range("A1")
With rngStart
.Offset(0, 0).Value = "Subject"
.Offset(0, 1).Value = "Start Date"
.Offset(0, 2).Value = "Start Time"
.Offset(0, 3).Value = "End Date"
.Offset(0, 4).Value = "End Time"
.Offset(0, 5).Value = "Location"
.Offset(0, 6).Value = "Categories"
End With
For Each MyItem In ItemstoCheck
If MyItem.Class = olAppointment Then
' MyItem is the appointment or meeting item we want,
' set obj reference to it
Set ThisAppt = MyItem
NextRow = WorksheetFunction.CountA(Range("A:A"))
With rngStart
.End(xlDown).End(xlUp).Offset(NextRow, 0).Value = ThisAppt.Subject
.End(xlDown).End(xlUp).Offset(NextRow, 1).Value = Format(ThisAppt.Start, "MM/DD/YYYY")
.End(xlDown).End(xlUp).Offset(NextRow, 2).Value = Format(ThisAppt.Start, "HH:MM AM/PM")
.End(xlDown).End(xlUp).Offset(NextRow, 3).Value = Format(ThisAppt.End, "MM/DD/YYYY")
.End(xlDown).End(xlUp).Offset(NextRow, 4).Value = Format(ThisAppt.End, "HH:MM AM/PM")
.End(xlDown).End(xlUp).Offset(NextRow, 5).Value = ThisAppt.Location
If ThisAppt.Categories <> "" Then
.End(xlDown).End(xlUp).Offset(NextRow, 6).Value = ThisAppt.Categories
Else
.End(xlDown).End(xlUp).Offset(NextRow, 6).Value = "n/a"
End If
End With
End If
Next MyItem
' make it pretty
Call Cool_Colors(rngStart)
Else
MsgBox "There are no appointments or meetings during" & _
"the time you specified. Exiting now.", vbCritical
End If
ExitProc:
Set myCalItems = Nothing
Set ItemstoCheck = Nothing
Set olNS = Nothing
Set olApp = Nothing
Set rngStart = Nothing
Set ThisAppt = Nothing
End Sub

plain text version

VBA:

Private Function Quote(MyText)
' from Sue Mosher's excellent book "Microsoft Outlook Programming"
Quote = Chr(34) & MyText & Chr(34)
End Function

plain text version

VBA:

Private Sub Cool_Colors(rng As Excel.Range)
'
' Lt Blue BG with white letters
'
'
With Range(rng, rng.End(xlToRight))
.Font.ColorIndex = 2
.Font.Bold = True
.HorizontalAlignment = xlCenter
.MergeCells = False
.AutoFilter
.CurrentRegion.Columns.AutoFit
With .Interior
.ColorIndex = 41
.Pattern = xlSolid
End With
End With
End Sub

Let's examine exactly what is going on here.

Our sub accepts two arguments, the start date and end date. The end date is optional, in case we only want to check one day. If the end date is "12:00:00 AM", this means no end date was specified, therefore we can set the end date = start date.

If the end date is later than the start date, the user might have made an error; we can simply exit and allow them to rerun the sub.

After hooking the Outlook application and setting a reference to the default Calendar, we build a string used to restrict the Calendar items returned to only those that start or end within the date range arguments passed to the sub. The Restrict method has a funny way of requiring quotation marks, so using the Quote UDF from Sue Mosher's book Microsoft Outlook Programming ensures that our quotation marks will be formatted properly for the Restrict method.

Then it's a simple matter of copying the information from each appointment to a new workbook. Notice that I hand selected certain properties to export; you can export whatever properties you want (see Outlook 2003 VBA Reference). All you need to do is update the two "With rngStart" sections.

I exported the date and time as two separate fields, if you wanted to combine them it would be something like:

plain text version

VBA:

Format(ThisAppt.Start, "MM/DD/YYYY HH:MM AM/PM")
Format(ThisAppt.End, "MM/DD/YYYY HH:MM AM/PM")

To export your Calendar items, just call the main sub like this:

plain text version

VBA:

Sub GetApptsFromOutlook()
Application.ScreenUpdating = False
Call GetCalData("7/20/2008", "8/6/2008")
Application.ScreenUpdating = True
End Sub

In the spirit of modularization, I broke out the code that pretties up the header row into its own sub; we just pass the header row as a Range object.

One minor issue we have to deal with is if there are no appointments, the code runs all the way to the For loop (after we have already populated the header row of the new worksheet) and then exits. This is because ItemstoCheck.Count returns 2147483647 (not 0), even if the date range we specified contains no appointments (based on my experiments). So if we pick a date range with no appointments, we'll end up with a useless blank spreadsheet with a populated header row.

The way we solve this problem is to add a line that checks to see if there are any actual objects found by the Restrict method, and exits if there's really nothing there. This line does just that.

plain text version

VBA:

If ItemstoCheck.Item(1) Is Nothing Then GoTo ExitProc

Here is a sample of the finished product.

(click to view larger image)

Enjoy,
JP

Share and Enjoy:

Print This Post |

Email This Post | Permalink |

Subscribe now!

Filed Under: Excel, Outlook, VBA, automation
Tags: Appointments, Excel, export, Outlook

This post has 1,028 views since August 10, 2008 – 9:15 am.

4 Responses to “Extract Calendar data from Outlook into Excel”
What can be done to pass variables to the Start and End Dates so that we don't have to update the Sub each and every time we want to change the dates?

I'm pretty novice at this stuff. I've tried passing variables via a Range with the date and input boxes

By Ryan on Aug 11, 2008
Hey Ryan,

The sub is designed so you can change the start and end dates as needed.

Sub GetApptsFromOutlook()
Application.ScreenUpdating = False
Call GetCalData("7/20/2008", "8/6/2008")
Application.ScreenUpdating = True
End Sub

Just change the two arguments (dates) as needed.

If you wanted to hard code the start and end dates, just change the first line of the sub to:

Private Sub GetCalData()

And you would have to add

Const StartDate As Date = 7/20/2008
Const EndDate As Date = 8/6/2008

right below that.

HTH,
JP

By JP on Aug 12, 2008
First, I want to say thanks for making this available. I was able to get it to pull from my default calendar in about 10 minutes.

How can I pull events from a public calendar?

Thanks,

Mary

By Mary Parkhouse on Nov 6, 2008
Hi Mary,

You can try to change line 57 to point to the public folder, but more likely you'll need to use CDO.

Although I did find a function here that might do what you want: http://www.outlookcode.com/codedetail.aspx?id=1164

--JP

By JP on Nov 6, 2008