Export Outlook Appointments to Excel

The following code exports appointments (also meetings) to Excel from Outlook. This code should be placed in a standard module in Excel. (See Where do I paste the code that I want to use in my workbook for placement assistance)

Since the code is late bound, we need to use the following enumeration when calling code meant for Outlook. I have, however, preserved most of the early bound references (as comments) so you can investigate the methods and properties of each object type.

Public Enum OlDefaultFolders
  olFolderCalendar = 9
  olFolderConflicts = 19
  olFolderContacts = 10
  olFolderDeletedItems = 3
  olFolderDrafts = 16
  olFolderInbox = 6
  olFolderJournal = 11
  olFolderJunk = 23
  olFolderLocalFailures = 21
  olFolderNotes = 12
  olFolderOutbox = 4
  olFolderSentMail = 5
  olFolderServerFailures = 22
  olFolderSyncIssues = 20
  olFolderTasks = 13
  olPublicFoldersAllPublicFolders = 18
End Enum

This code should be placed at the top of a standard module.

Export Appointments

This code will return appointments in the local default Calendar folder and write them to an array. What you choose to do with it is up to you — put them into a listbox, or dump them onto a worksheet.

An optional header row is also provided, so you can see what each column of values represents. I chose to grab every possible property of the AppointmentItem Object, where possible.

Function ExportAppts(Optional headerRow As Boolean = False) As String()

Dim olApp As Object  '  Outlook.Application
Dim olNS As Object  '  Outlook.Namespace
Dim apptFolderItems As Object  '  Outlook.items
Dim folderItem As Object
Dim appt As Object  '  Outlook.AppointmentItem
Dim tempString() As String
Dim i As Long
Dim numRows As Long
Dim startRow As Long

  Set olApp = GetOutlookApp
  Set olNS = GetNS(olApp)
  Set apptFolderItems = GetItems(olNS, olFolderCalendar)

  ' if calling procedure wants header row
  If headerRow Then
    startRow = 1
  Else
    startRow = 0
  End If

  numRows = apptFolderItems.count

  ' resize array
  ReDim tempString(1 To (numRows + startRow), 1 To 27)

  ' loop through folder items
  For i = 1 To numRows
    Set folderItem = apptFolderItems.item(i)

    If IsAppt(folderItem) Then
      Set appt = folderItem
    End If

    With appt
      tempString(i + startRow, 1) = .AllDayEvent
      tempString(i + startRow, 2) = .BillingInformation
      tempString(i + startRow, 3) = .Body
      tempString(i + startRow, 4) = .BusyStatus
      tempString(i + startRow, 5) = .Categories
      tempString(i + startRow, 6) = .Companies
      tempString(i + startRow, 7) = .CreationTime
      tempString(i + startRow,  = .Duration
      tempString(i + startRow, 9) = .End
      tempString(i + startRow, 10) = .Importance
      tempString(i + startRow, 11) = .IsRecurring
      tempString(i + startRow, 12) = .LastModificationTime
      tempString(i + startRow, 13) = .location
      tempString(i + startRow, 14) = .MeetingStatus
      tempString(i + startRow, 15) = .Mileage
      tempString(i + startRow, 16) = .OptionalAttendees
      tempString(i + startRow, 17) = .Organizer
      tempString(i + startRow, 18) = .RecurrenceState
      tempString(i + startRow, 19) = .ReminderMinutesBeforeStart
      tempString(i + startRow, 20) = .ReminderSet
      tempString(i + startRow, 21) = .RequiredAttendees
      tempString(i + startRow, 22) = .Resources
      tempString(i + startRow, 23) = .ResponseStatus
      tempString(i + startRow, 24) = .Sensitivity
      tempString(i + startRow, 25) = .Size
      tempString(i + startRow, 26) = .Start
      tempString(i + startRow, 27) = .Subject
    End With

  Next i

  ' first row of array should be header values
  If headerRow Then
    tempString(1, 1) = "AllDayEvent"
    tempString(1, 2) = "BillingInformation"
    tempString(1, 3) = "Body"
    tempString(1, 4) = "BusyStatus"
    tempString(1, 5) = "Categories"
    tempString(1, 6) = "Companies"
    tempString(1, 7) = "CreationTime"
    tempString(1,  = "Duration"
    tempString(1, 9) = "End"
    tempString(1, 10) = "Importance"
    tempString(1, 11) = "IsRecurring"
    tempString(1, 12) = "LastModificationTime"
    tempString(1, 13) = "Location"
    tempString(1, 14) = "MeetingStatus"
    tempString(1, 15) = "Mileage"
    tempString(1, 16) = "OptionalAttendees"
    tempString(1, 17) = "Organizer"
    tempString(1, 18) = "RecurrenceState"
    tempString(1, 19) = "ReminderMinutesBeforeStart"
    tempString(1, 20) = "ReminderSet"
    tempString(1, 21) = "RequiredAttendees"
    tempString(1, 22) = "Resources"
    tempString(1, 23) = "ResponseStatus"
    tempString(1, 24) = "Sensitivity"
    tempString(1, 25) = "Size"
    tempString(1, 26) = "Start"
    tempString(1, 27) = "Subject"
  End If

  ExportAppts = tempString
End Function

Helper Functions

Visit Utility Functions for IsAppt, GetNS, GetOutlookApp, GetItems.

Sample Usage

This sample procedure gets the appointments from my local Calendar and pastes the result into Excel, including a header row:

Sub GetApptInfo()

Dim results() As String

  ' get contacts
  results = ExportAppts(True)

  ' paste onto worksheet
  Range(cells(1, 1), cells(UBound(results), UBound(results, 2))).value = results

End Sub

The sample workbook includes the code and a userform so you can see how the results would be put into a listbox.

Download workbook for Excel 2003