Extract Calendar data from Outlook, Redux
March 31, 2009 • JP • 11 Comments • Rate This Article
In Extract Calendar Data from Outlook into Excel, I posted a method for writing Outlook appointments to an Excel worksheet.
Here is an updated function that uses a bit less code, with one disadvantage: it doesn't extract recurring appointments. Use the original code if you have recurring appointments. Or use both; the original to get all appointments, and this one to get only originals (not the recurrences).
It uses the same array techniques as used in Export Outlook Contacts to Excel and Export Outlook Tasks to Excel.
Dim bWeStartedOutlook As Boolean
Private Function GetCalData(StartDate As Date, _
Optional EndDate As Date) As Boolean
' Exports calendar information to Excel worksheet
' -------------------------------------------------
' Notes:
' If Outlook is not open, it still works, but much
' slower (~8 secs vs. 2 secs w/ Outlook open).
' End Date is optional, if you want to pull from
' only one day, use: Call GetCalData("7/14/2008")
' -------------------------------------------------
Dim ThisAppt As Object ' Outlook.AppointmentItem
Dim MyItem As Object
Dim StringToCheck As String
Dim i 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
' get Outlook
Dim olApp As Object ' Outlook.Application
Set olApp = GetOutlookApp
If olApp Is Nothing Then
MsgBox "Cannot start Outlook.", vbExclamation
GoTo ExitProc
End If
' get default Calendar
Dim olNS As Object ' Outlook.Namespace
Dim myCalItems As Object ' Outlook.Items
Set olNS = olApp.GetNamespace("MAPI")
Set myCalItems = olNS.GetDefaultFolder(9).Items ' olFolderCalendar
' ------------------------------------------------------------------
' the following code adapted from:
' http://www.outlookcode.com/article.aspx?id=30
'
With myCalItems
.Sort "[Start]", False
.IncludeRecurrences = False
End With
'
StringToCheck = "[Start] >= " & Quote(StartDate & " 12:00 AM") & _
" AND [End] <= " & Quote(EndDate & " 11:59 PM")
Debug.Print StringToCheck
'
Dim ItemstoCheck As Object ' Outlook.Items
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 up worksheet
Dim MyBook As Excel.Workbook
Dim xlSht As Excel.Worksheet
Dim rngStart As Excel.Range
Dim rngHeader As Excel.Range
Set MyBook = Excel.Workbooks.Add
Set xlSht = MyBook.Sheets(1)
Set rngStart = xlSht.Range("A1")
Set rngHeader = Range(rngStart, rngStart.Offset(0, 6))
' with assistance from Jon Peltier http://peltiertech.com/WordPress and
' http://support.microsoft.com/kb/306022
rngHeader.Value = Array("Subject", "Start Date", "Start Time", "End Date", _
"End Time", "Location", "Categories")
' create/fill array with exported info
Dim ColCount As Long
Dim arrData As Variant
ColCount = rngHeader.Columns.Count
ReDim arrData(1 To ItemstoCheck.Count, 1 To ColCount)
For i = 1 To ItemstoCheck.Count
Set ThisAppt = ItemstoCheck.Item(i)
arrData(i, 1) = ThisAppt.Subject
arrData(i, 2) = Format(ThisAppt.Start, "MM/DD/YYYY")
arrData(i, 3) = Format(ThisAppt.Start, "HH:MM AM/PM")
arrData(i, 4) = Format(ThisAppt.End, "MM/DD/YYYY")
arrData(i, 5) = Format(ThisAppt.End, "HH:MM AM/PM")
arrData(i, 6) = ThisAppt.Location
If ThisAppt.Categories <> "" Then
arrData(i, 7) = ThisAppt.Categories
End If
Next i
rngStart.Offset(1, 0).Resize(ItemstoCheck.Count, ColCount).Value = arrData
Else
MsgBox "There are no original appointments or meetings during" & _
"the time you specified. Exiting now.", vbCritical
GoTo ExitProc
End If
' if we got this far, assume success
GetCalData = True
ExitProc:
If bWeStartedOutlook Then
olApp.Quit
End If
Set myCalItems = Nothing
Set ItemstoCheck = Nothing
Set olNS = Nothing
Set olApp = Nothing
Set rngStart = Nothing
Set ThisAppt = Nothing
End Function
Private Function GetCalData(StartDate As Date, _
Optional EndDate As Date) As Boolean
' Exports calendar information to Excel worksheet
' -------------------------------------------------
' Notes:
' If Outlook is not open, it still works, but much
' slower (~8 secs vs. 2 secs w/ Outlook open).
' End Date is optional, if you want to pull from
' only one day, use: Call GetCalData("7/14/2008")
' -------------------------------------------------
Dim ThisAppt As Object ' Outlook.AppointmentItem
Dim MyItem As Object
Dim StringToCheck As String
Dim i 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
' get Outlook
Dim olApp As Object ' Outlook.Application
Set olApp = GetOutlookApp
If olApp Is Nothing Then
MsgBox "Cannot start Outlook.", vbExclamation
GoTo ExitProc
End If
' get default Calendar
Dim olNS As Object ' Outlook.Namespace
Dim myCalItems As Object ' Outlook.Items
Set olNS = olApp.GetNamespace("MAPI")
Set myCalItems = olNS.GetDefaultFolder(9).Items ' olFolderCalendar
' ------------------------------------------------------------------
' the following code adapted from:
' http://www.outlookcode.com/article.aspx?id=30
'
With myCalItems
.Sort "[Start]", False
.IncludeRecurrences = False
End With
'
StringToCheck = "[Start] >= " & Quote(StartDate & " 12:00 AM") & _
" AND [End] <= " & Quote(EndDate & " 11:59 PM")
Debug.Print StringToCheck
'
Dim ItemstoCheck As Object ' Outlook.Items
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 up worksheet
Dim MyBook As Excel.Workbook
Dim xlSht As Excel.Worksheet
Dim rngStart As Excel.Range
Dim rngHeader As Excel.Range
Set MyBook = Excel.Workbooks.Add
Set xlSht = MyBook.Sheets(1)
Set rngStart = xlSht.Range("A1")
Set rngHeader = Range(rngStart, rngStart.Offset(0, 6))
' with assistance from Jon Peltier http://peltiertech.com/WordPress and
' http://support.microsoft.com/kb/306022
rngHeader.Value = Array("Subject", "Start Date", "Start Time", "End Date", _
"End Time", "Location", "Categories")
' create/fill array with exported info
Dim ColCount As Long
Dim arrData As Variant
ColCount = rngHeader.Columns.Count
ReDim arrData(1 To ItemstoCheck.Count, 1 To ColCount)
For i = 1 To ItemstoCheck.Count
Set ThisAppt = ItemstoCheck.Item(i)
arrData(i, 1) = ThisAppt.Subject
arrData(i, 2) = Format(ThisAppt.Start, "MM/DD/YYYY")
arrData(i, 3) = Format(ThisAppt.Start, "HH:MM AM/PM")
arrData(i, 4) = Format(ThisAppt.End, "MM/DD/YYYY")
arrData(i, 5) = Format(ThisAppt.End, "HH:MM AM/PM")
arrData(i, 6) = ThisAppt.Location
If ThisAppt.Categories <> "" Then
arrData(i, 7) = ThisAppt.Categories
End If
Next i
rngStart.Offset(1, 0).Resize(ItemstoCheck.Count, ColCount).Value = arrData
Else
MsgBox "There are no original appointments or meetings during" & _
"the time you specified. Exiting now.", vbCritical
GoTo ExitProc
End If
' if we got this far, assume success
GetCalData = True
ExitProc:
If bWeStartedOutlook Then
olApp.Quit
End If
Set myCalItems = Nothing
Set ItemstoCheck = Nothing
Set olNS = Nothing
Set olApp = Nothing
Set rngStart = Nothing
Set ThisAppt = Nothing
End Function
Private Function Quote(MyText)
' from Sue Mosher's excellent book "Microsoft Outlook Programming"
Quote = Chr(34) & MyText & Chr(34)
End Function
' from Sue Mosher's excellent book "Microsoft Outlook Programming"
Quote = Chr(34) & MyText & Chr(34)
End Function
Function GetOutlookApp() As Object
On Error Resume Next
Set GetOutlookApp = GetObject(, "Outlook.Application")
If Err.Number <> 0 Then
Set GetOutlookApp = CreateObject("Outlook.Application")
bWeStartedOutlook = True
End If
On Error GoTo 0
End Function
On Error Resume Next
Set GetOutlookApp = GetObject(, "Outlook.Application")
If Err.Number <> 0 Then
Set GetOutlookApp = CreateObject("Outlook.Application")
bWeStartedOutlook = True
End If
On Error GoTo 0
End Function
Usage:
Sub test()
Dim success As Boolean
success = GetCalData("3/1/2009", "3/31/2009")
End Sub
Dim success As Boolean
success = GetCalData("3/1/2009", "3/31/2009")
End Sub
Automation, Excel, Outlook ·
Rate This Article:
(No Ratings Yet)
Loading ...What now?
Subscribe To The Blog
Email This Article
Follow Me On Twitter
My Facebook Page
Or just keep reading:
I'm just an average guy who writes VBA code for a living. This is my personal blog. Excel and Outlook are my thing, with a sprinkle of Access and Word here and there. Follow this space if you want to learn more about VBA. Keep Reading »
Previous Post: Extract GAL members to Excel
Next Post: Q1 2009 Wrap up
very nice
can you tell me how i can get it to also
add the Description field to it
and also how to have it get the data from other then the default calendar
nothing i have tried has worked
thans again for this sample it is very helpful
Randall,
Change this line to
Set rngHeader = Range(rngStart, rngStart.Offset(0, 7))
and this line to
rngHeader.Value = Array("Subject", "Start Date", "Start Time", "End Date", _
"End Time", "Location", "Categories", "Body")
and add
arrData(i, 8 ) = ThisAppt.Body
right before the end of the For loop.
Thank you this worked perfectly
one last Question if i want the export to be from other then the default calendar can i do this??
Thanks again
Yes, you need to point myCalItems to another folder that holds calendar items. If you browse the comments for Extract Calendar data from Outlook into Excel, there are some samples there of references to public folders.
Question: How would one grab other data such as "Attendees" (on SCHEDULING tab) instead of "Location" or "Body" (on APPOINTMENT tab).
I get you'll need something close to:
arrData(i, 8 ) = ThisAppt.Body
would it be:
arrData(i, 9 ) = ThisAppt.Attendees
??
Thanks for any insights.
Jeff,
You want the Recipients collection, but you'll need to iterate it in order to get each attendee.
ThisAppt.Organizer will give you the name of the person who originally scheduled the meeting, although they are also listed as a Recipient object.
Check ThisAppt.Recipients.Count to see how many attendees there are.
Then you'll need to iterate through the collection like this
Debug.Print ThisAppt.Recipients.Item(i)
Next i
How you want to integrate that to the existing code is up to you. You could create one big string with all the attendee names and then assign it to another element of the array.
Really great post by the way!
Hi, JP!
I absolutely love your code! However, I'm about to cry. I've been working soo hard on it for the last week, but I can't quite get it to do what I want! So, I'm going to ask my questions, simple as they may be, and pray someone has the patience to help!
I used your previous Outlook -> Excel code at http://www.codeforexcelandoutlook.com/blog/2008/08/extract-calendar-data-from-outlook-into-excel/ It works great!
My challenge is, once I get all my appointments into the new excel spreadsheet, I want to make a pivot table out of them (aka- my timesheet!). I recorded a macro of myself doing this, but am having trouble setting up the range. Here's what I have (GetCalData calls MakePivotTable after the Cool_Colors code runs. the sheet with the list of all my appointments is "MyOutlookAppts", the sheet with my pivot table is "TimeByCategory". Both are in MyBook. When I run this it fails at "Range("rngstart").Select" and tells me "method 'range' of object _global failed" how do i declare the range on an inactive sheet? how do i get it to figure out the range of all of my appointments, and then use that for the pivot table?)
'make pivot table to display time spent each day in each category
Dim rngEnd As Excel.Range ' end of data on Outlook appts
'find the end of outlook appts
Range("rngstart").Select
Set rngEnd = Range("rngStart").SpecialCells(xlCellTypeLastCell)
'(note: will include formatted cells as part of range)
Sheets("TimeByCategory").Select
Range("A4").Select
ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:= _
"MyOutlookAppts!R4C1:R999C5", Version:=xlPivotTableVersion12). _
CreatePivotTable TableDestination:="TimeByCategory!R4C1", TableName:= _
"PivotTable6", DefaultVersion:=xlPivotTableVersion12
Sheets("TimeByCategory").Select
Cells(4, 1).Select
With ActiveSheet.PivotTables("PivotTable6").PivotFields("Start Time")
.Orientation = xlRowField
.Position = 1
End With
With ActiveSheet.PivotTables("PivotTable6").PivotFields("Categories")
.Orientation = xlColumnField
.Position = 1
End With
ActiveSheet.PivotTables("PivotTable6").AddDataField ActiveSheet.PivotTables( _
"PivotTable6").PivotFields("Hrs Duration"), "Sum of Hrs Duration", xlSum
'Group by date
Range("A6").Select
Selection.Group start:=True, End:=True, By:=1, Periods:=Array(False, _
False, False, True, False, False, False)
Thanks for any help you can give!!!!!
~Becca the n00b!
Remove the quotes from rngstart and it looks like it should work. rngstart is a variable that represents a Range object — if you put it in double quotes, it becomes a string literal.
See if that helps!
Thanks for the code, I have a fair knowledge of Excel and ok w/VB. I'm trying to add this into an existing excel file. Where in Vb Editor do I enter this code? Do you have a copy of the excel that I would be able to look at?
In the VB Editor, you can either insert a new standard module or add the code to an existing one.
To insert a new standard module, select the appropriate VB Project in the Project Explorer. (If you can't see the Project Explorer, press Ctrl+R). Go to Insert Menu, Module. Copy and paste ALL three code sections above into the module. Also, copy the test() procedure if you want to use it to call the function.