Exporting Appointments from Outlook to Excel

I put this solution together for Allen, who had seen my post demonstrating how to export Outlook messages to Excel and asked if I could create a similar macro to export appointments. Allen went on to explain that his organization uses a shared calendar and that periodically he would like to export its contents to Excel. For each appointment, Allen wants to export the organizer (i.e. the person that added the appointment to the calendar), when the appointment was added, the appointment’s subject, when it starts, and who was invited. To make it a little easier for Allen, I broke “who was invited” down into two groups: required and optional attendees. The solution itself is nearly identical to the one I used to export messages.

Instructions.

Follow these instructions to add the code to Outlook.

1. Start Outlook
2. Press ALT + F11 to open the Visual Basic Editor
3. If not already expanded, expand Microsoft Office Outlook Objects
4. If not already expanded, expand Modules
5. Select an existing module (e.g. Module1) by double-clicking on it or create a new module by right-clicking Modules and selecting Insert → Module.
6. Copy the code from the code snippet box and paste it into the right-hand pane of Outlook’s VB Editor window
7. Click the diskette icon on the toolbar to save the changes
8. Close the VB Editor

Sub ExportAppointmentsToExcel()
    Const SCRIPT_NAME = "Export Appointments to Excel"
    Dim olkFld As Object, _
        olkLst As Object, _
        olkApt As Object, _
        excApp As Object, _
        excWkb As Object, _
        excWks As Object, _
        lngRow As Long, _
        intCnt As Integer
    Set olkFld = Application.ActiveExplorer.CurrentFolder
    If olkFld.DefaultItemType = olAppointmentItem Then
        strFilename = InputBox("Enter a filename (including path) to save the exported appointments to.", SCRIPT_NAME)
        If strFilename <> "" 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) = "Organizer"
                .Cells(1, 2) = "Created"
                .Cells(1, 3) = "Subject"
                .Cells(1, 4) = "Start"
                .Cells(1, 5) = "Required"
                .Cells(1, 6) = "Optional"
            End With
            lngRow = 2
            Set olkLst = olkFld.Items
            olkLst.Sort "[Start]"
            olkLst.IncludeRecurrences = True
            'Write appointments to spreadsheet
            For Each olkApt In Application.ActiveExplorer.CurrentFolder.Items
                'Only export appointments
                If olkApt.Class = olAppointment Then
                    'Add a row for each field in the message you want to export
                    excWks.Cells(lngRow, 1) = olkApt.Organizer
                    excWks.Cells(lngRow, 2) = olkApt.CreationTime
                    excWks.Cells(lngRow, 3) = olkApt.Subject
                    excWks.Cells(lngRow, 4) = olkApt.Start
                    excWks.Cells(lngRow, 5) = olkApt.RequiredAttendees
                    excWks.Cells(lngRow, 6) = olkApt.OptionalAttendees
                    lngRow = lngRow + 1
                    intCnt = intCnt + 1
                End If
            Next
            excWks.Columns("A:F").AutoFit
            excWkb.SaveAs strFilename
            excWkb.Close
            MsgBox "Process complete.  A total of " & intCnt & " 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

Using the Code.

1. With Outlook open select a calendar.
2. Run the macro.
3. When prompted, enter a filename to save the export to. You can cancel the export by leaving the file name blank.
4. The macro will display a dialog-box when it’s finished. The dialog-box includes a count of the number of appointments exported.

Revisions.

1

2

3

4

Revision 1.

This revision is for Oradev, who asked for two changes to the original script. First, Oradev wants to be able to export appointments falling within a date range. To accomplish this, I’ve added a dialog-box that prompts for the date range. Second, Oradev needs a different set of data from each appointment. Where the original code exports organizer, date created, subject start time, and attendees, this version exports category, subject, start date, end date, start time, end time, the length of the appointment in hours, and attendees. The export is sorted by category and the appointment length column is summed.

Oradev will use the instructions from the original post to add the code to Outlook.

Sub ExportAppointmentsToExcel()
    Const SCRIPT_NAME = "Export Appointments to Excel (Rev 1)"
    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 = Application.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)
        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) = "Category"
                .Cells(1, 2) = "Subject"
                .Cells(1, 3) = "Starting Date"
                .Cells(1, 4) = "Ending Date"
                .Cells(1, 5) = "Start Time"
                .Cells(1, 6) = "End Time"
                .Cells(1, 7) = "Hours"
                .Cells(1, 8) = "Attendees"
            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)
                    'Add a row for each field in the message you want to export
                    excWks.Cells(lngRow, 1) = olkApt.Categories
                    excWks.Cells(lngRow, 2) = olkApt.Subject
                    excWks.Cells(lngRow, 3) = Format(olkApt.Start, "mm/dd/yyyy")
                    excWks.Cells(lngRow, 4) = Format(olkApt.End, "mm/dd/yyyy")
                    excWks.Cells(lngRow, 5) = Format(olkApt.Start, "hh:nn ampm")
                    excWks.Cells(lngRow, 6) = Format(olkApt.End, "hh:nn ampm")
                    excWks.Cells(lngRow, 7) = DateDiff("n", olkApt.Start, olkApt.End) / 60
                    excWks.Cells(lngRow, 7).NumberFormat = "0.00"
                    excWks.Cells(lngRow, 8) = strLst
                    lngRow = lngRow + 1
                    lngCnt = lngCnt + 1
                End If
            Next
            excWks.Columns("A:H").AutoFit
            excWks.Range("A1:H" & lngRow - 1).Sort Key1:="Category", Order1:=xlAscending, Header:=xlYes
            excWks.Cells(lngRow, 7) = "=sum(G2:G" & lngRow - 1 & ")"
            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

Revision 2.

This revision is for Kimberly. Kimberly asked for a version based on revision 1, with a few changes. Specifically

1. Export a fixed list of calendars
2. Include the name of the calendar with each exported appointment
3. Export to a fixed file name rather than having to enter the file name each time

Kimberly will use the instructions from the original post to add the code to Outlook.

Sub ExportAppointmentsToExcel()
    'On the next line, edit the list of calendars you want to export.  Each entry is the path to a calendar.  Entries are separated by a comma.
    Const CAL_LIST = "Calendar1,Calendar2"
    'On the next line, edit the path to and name of the Excel spreadsheet to export to
    Const EXCEL_FILE = "c:\users\david\documents\testarea\kimberly.xlsx"
    Const SCRIPT_NAME = "Export Appointments to Excel (Rev 2)"
    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, _
        arrCal As Variant, _
        varCal As Variant
    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"
    Set excApp = CreateObject("Excel.Application")
    Set excWkb = excApp.Workbooks.Add()
    Set excWks = excWkb.Worksheets(1)
    'Write Excel Column Headers
    With excWks
        .Cells(1, 1) = "Calendar"
        .Cells(1, 2) = "Category"
        .Cells(1, 3) = "Subject"
        .Cells(1, 4) = "Starting Date"
        .Cells(1, 5) = "Ending Date"
        .Cells(1, 6) = "Start Time"
        .Cells(1, 7) = "End Time"
        .Cells(1, 8) = "Hours"
        .Cells(1, 9) = "Attendees"
    End With
    lngRow = 2
    arrCal = Split(CAL_LIST, ",")
    For Each varCal In arrCal
        Set olkFld = OpenOutlookFolder(CStr(varCal))
        If TypeName(olkFld) <> "Nothing" Then
            If olkFld.DefaultItemType = olAppointmentItem Then
                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)
                        'Add a row for each field in the message you want to export
                        excWks.Cells(lngRow, 1) = olkFld.FolderPath
                        excWks.Cells(lngRow, 2) = olkApt.Categories
                        excWks.Cells(lngRow, 3) = olkApt.Subject
                        excWks.Cells(lngRow, 4) = Format(olkApt.Start, "mm/dd/yyyy")
                        excWks.Cells(lngRow, 5) = Format(olkApt.End, "mm/dd/yyyy")
                        excWks.Cells(lngRow, 6) = Format(olkApt.Start, "hh:nn ampm")
                        excWks.Cells(lngRow, 7) = Format(olkApt.End, "hh:nn ampm")
                        excWks.Cells(lngRow, 8) = DateDiff("n", olkApt.Start, olkApt.End) / 60
                        excWks.Cells(lngRow, 8).NumberFormat = "0.00"
                        excWks.Cells(lngRow, 9) = strLst
                        lngRow = lngRow + 1
                        lngCnt = lngCnt + 1
                    End If
                Next
            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
        Else
            MsgBox "I could not find a folder named " & varCal & ".  Folder skipped.  I will continue processing the remaining folders.", vbExclamation + vbOKOnly, SCRIPT_NAME
        End If
    Next
    excWks.Columns("A:I").AutoFit
    excWks.Range("A1:I" & lngRow - 1).Sort Key1:="Category", Order1:=xlAscending, Header:=xlYes
    excWks.Cells(lngRow, 8) = "=sum(H2:H" & lngRow - 1 & ")"
    excWkb.SaveAs EXCEL_FILE
    excWkb.Close
    MsgBox "Process complete.  I exported a total of " & lngCnt & " appointments were exported.", vbInformation + vbOKOnly, SCRIPT_NAME
    Set excWks = Nothing
    Set excWkb = Nothing
    Set excApp = Nothing
    Set olkApt = Nothing
    Set olkLst = Nothing
    Set olkFld = Nothing
End Sub

Private Function OpenOutlookFolder(strFolderPath As String) As Outlook.MAPIFolder
    ' Purpose: Opens an Outlook folder from a folder path.
    ' Written: 4/24/2009
    ' Author:  David Lee
    ' Outlook: All versions
    Dim arrFolders As Variant, _
        varFolder As Variant, _
        bolBeyondRoot As Boolean
    On Error Resume Next
    If strFolderPath = "" Then
        Set OpenOutlookFolder = Nothing
    Else
        Do While Left(strFolderPath, 1) = "\"
            strFolderPath = Right(strFolderPath, Len(strFolderPath) - 1)
        Loop
        arrFolders = Split(strFolderPath, "\")
        For Each varFolder In arrFolders
            Select Case bolBeyondRoot
                Case False
                    Set OpenOutlookFolder = Outlook.Session.Folders(varFolder)
                    bolBeyondRoot = True
                Case True
                    Set OpenOutlookFolder = OpenOutlookFolder.Folders(varFolder)
            End Select
            If Err.Number <> 0 Then
                Set OpenOutlookFolder = Nothing
                Exit For
            End If
        Next
    End If
    On Error GoTo 0
End Function

This revision requires a list of calendars to export. The list must be composed of the paths to the calendars Kimberly wants to export. In case Kimberly is not familiar with how Outlook folder paths work, here’s an explanation.

A folder path in Outlook is essentially the same as a folder path in the file system. The one difference being that Outlook folder paths do not include a drive letter. The path to a folder is a list of all the folders from the root to the target folder with each folder name separated from the preceding folder name by a backslash (i.e. \). Consider the following folder structure:

Mailbox - Doe, John
    - Calendar
    - Inbox
    - Tasks
Personal Folders
    + Marketing
        + Proposals
        + Reviews
    + Projects
        + Project 1
        + Project 2

The path to “Inbox” is “Mailbox – Doe, John\Inbox”.
The path to “Reviews” is “Personal Folders\Marketing\Reviews”.
The path to “Project 1” is “Personal Folders\Projects\Project 1”.

Revision 3.

This revision is for Phil at LightSpeed Fitness. Phil asked for a version that limits the export to only those appointments with a certain word or phrase in the subject line.

Phil will use the instructions from the original post to add the code to Outlook.

Sub ExportAppointmentsToExcel()
    Const SCRIPT_NAME = "Export Appointments to Excel (Rev 3)"
    Dim olkFld As Object, _
        olkLst As Object, _
        olkApt As Object, _
        excApp As Object, _
        excWkb As Object, _
        excWks As Object, _
        lngRow As Long, _
        lngCnt As Long, _
        strFil As String, _
        strFlt As String
    Set olkFld = Application.ActiveExplorer.CurrentFolder
    If olkFld.DefaultItemType = olAppointmentItem Then
        strFil = InputBox("Enter a filename (including path) to save the exported appointments to.", SCRIPT_NAME)
        If strFil <> "" Then
            strFlt = InputBox("Enter the string to search the subject for.", SCRIPT_NAME)
            If strFlt <> "" 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) = "Subject"
                    .Cells(1, 2) = "Location"
                    .Cells(1, 3) = "Start Date"
                    .Cells(1, 4) = "End Date"
                    .Cells(1, 5) = "Start Time"
                    .Cells(1, 6) = "End Time"
                    .Cells(1, 7) = "Duration (Minutes)"
                End With
                lngRow = 2
                Set olkLst = olkFld.Items
                olkLst.Sort "[Start]"
                olkLst.IncludeRecurrences = True
                Set olkRes = olkLst.Restrict("@SQL=" & Chr(34) & "http://schemas.microsoft.com/mapi/proptag/0x0037001E" & Chr(34) & " ci_phrasematch " & "'" & strFlt & "'")
                'Write appointments to spreadsheet
                For Each olkApt In olkRes
                    'Only export appointments
                    If olkApt.Class = olAppointment Then
                        'Add a row for each field in the message you want to export
                        excWks.Cells(lngRow, 1) = olkApt.Subject
                        excWks.Cells(lngRow, 2) = olkApt.Location
                        excWks.Cells(lngRow, 3) = Format(olkApt.Start, "mm/dd/yyyy")
                        excWks.Cells(lngRow, 4) = Format(olkApt.End, "mm/dd/yyyy")
                        excWks.Cells(lngRow, 5) = Format(olkApt.Start, "hh:nn AMPM")
                        excWks.Cells(lngRow, 6) = Format(olkApt.End, "hh:nn AMPM")
                        excWks.Cells(lngRow, 7) = olkApt.Duration
                        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
            Else
                MsgBox "Operation cancelled.  You must enter a search term for this macro to work.", vbCritical + vbOKOnly, SCRIPT_NAME
            End If
        Else
            MsgBox "Operation cancelled.  You must enter a filename and path to save the exported appointments to.", vbCritical + 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

Revision 4.

I created this revision for a reader named Julien. Julien asked for a version that

1. Is triggered by adding an appointment to a calendar
2. Exports to an existing workbook (the solution should overwrite the workbook each time)
3. Exports from the current date forward
4. Only exports appointments belonging to a specified category

This version implements all four of those features. In addition to exporting each time Julien adds an item belonging to the triggering category, it will also export when he edits an item belonging to the category. Unfortunately, the code cannot detect when Julien deletes an item belonging to the category. To handle that, I’m giving Julien a way to manually run the export. If he deletes an item belonging to the category, then he can run the export himself. He’ll do that by running the ManualExport macro.

One caveat. This version only monitors the default calendar. If Julien needs to monitor some other calendar, then I’ll need to modify the code.

The code comes in two parts. This is part #1. Follow these instructions to add this part of the code to Outlook.

1. Start Outlook
2. Press ALT + F11 to open the Visual Basic Editor
3. If not already expanded, expand Microsoft Office Outlook Objects
4. Right-click on Class Modules, select Insert → Module
5. In the Properties panel click on Name and enter clsCalendarMonitor
6. Copy the code from the code snippet box and paste it into the right-hand pane of Outlook’s VB Editor window
7. Edit the code as needed. I included a comment where changes are needed or allowed.
8. Click the diskette icon on the toolbar to save the changes

'On the next line, edit the number of calendar days to export starting with today
Const DAYS_TO_INCLUDE = 90
'On the next line, edit the path to the workbook the solution is to update
Const WORKBOOK_PATH = "c:\users\david\documents\testarea\julien.xlsx"
'On the next line, edit the name of the category to key on.  The solution will only export appointments that have this category applied.
Const CAT_NAME = "Testing"
Const SCRIPT_NAME = "Export Appointments to Excel (Rev 4)"

Private WithEvents olkFld As Outlook.Items

Private Sub Class_Initialize()
    Set olkFld = Session.GetDefaultFolder(olFolderCalendar).Items
End Sub

Private Sub Class_Terminate()
    Set olkFld = Nothing
End Sub

Private Sub olkFld_ItemAdd(ByVal Item As Object)
    If InStr(1, Item.Categories, CAT_NAME) > 0 Then
        ExportAppointmentsToExcel
    End If
End Sub

Private Sub olkFld_ItemChange(ByVal Item As Object)
    If InStr(1, Item.Categories, CAT_NAME) > 0 Then
        ExportAppointmentsToExcel
    End If
End Sub

Public Sub ExportAppointmentsToExcel()
    Dim olkLst As Object, _
        olkRes As Object, _
        olkApt As Object, _
        excApp As Object, _
        excWkb As Object, _
        excWks As Object, _
        lngRow As Long
    Set excApp = CreateObject("Excel.Application")
    Set excWkb = excApp.Workbooks.Open(WORKBOOK_PATH)
    Set excWks = excWkb.Worksheets(1)
    excWks.Range("A2:I" & excWks.UsedRange.rows.Count).rows.Delete
    lngRow = 2
    Set olkLst = olkFld
    olkLst.Sort "[Start]"
    olkLst.IncludeRecurrences = True
    Set olkRes = olkLst.Restrict("[Start] >= '" & VBA.Format(Now, "ddddd h:nn AMPM") & "' AND [Start] <= '" & VBA.Format(DateAdd("d", DAYS_TO_INCLUDE, Now), "ddddd h:nn AMPM") & "'")
    'Write appointments to spreadsheet
    For Each olkApt In olkRes
        'Only export appointments
        If olkApt.Class = olAppointment Then
            If InStr(1, olkApt.Categories, CAT_NAME) > 0 Then
                'Add a row for each field in the message you want to export
                excWks.Cells(lngRow, 1) = olkApt.Categories
                excWks.Cells(lngRow, 2) = olkApt.Subject
                excWks.Cells(lngRow, 3) = olkApt.Organizer
                excWks.Cells(lngRow, 4) = VBA.Format(olkApt.Start, "Short Date")
                excWks.Cells(lngRow, 5) = VBA.Format(olkApt.End, "Short Date")
                excWks.Cells(lngRow, 6) = VBA.Format(olkApt.Start, "Long Time")
                excWks.Cells(lngRow, 7) = VBA.Format(olkApt.End, "Long Time")
                excWks.Cells(lngRow, 8) = olkApt.RequiredAttendees
                excWks.Cells(lngRow, 9) = olkApt.OptionalAttendees
                lngRow = lngRow + 1
                lngCnt = lngCnt + 1
            End If
        End If
        DoEvents
    Next
    excWks.Columns("A:I").AutoFit
    excWkb.Close True
    Set excWks = Nothing
    Set excWkb = Nothing
    Set excApp = Nothing
    Set olkApt = Nothing
    Set olkLst = Nothing
End Sub

This is part #2 of the code. Follow these instructions to add this portion of the code to Outlook.

1. If not already expanded, expand Microsoft Office Outlook Objects and click on ThisOutlookSession
2. Copy the code from the code snippet box and paste it into the right-hand pane of Outlook’s VB Editor window
3. Click the diskette icon on the toolbar to save the changes
4. Close the VB Editor
5. Click File and select Options
6. When the Outlook Options dialog appears click Trust Center then click the Trust Center Settings button
7. Click Macro Settings
8. Select either of the two bottom settings (i.e. “Notifications for all macros” or “Enable all macros (not recommended; potentially dangerous code can run)”. The choice of which to choose is up to you. If you select “Notifications”, then you’ll be prompted at times to enable macros. If you pick “Enable all” then there’s a chance that a malicious macro could run. It’s a question of how much risk you want to assume.
9. Click Ok until the dialog-boxes have all closed
10. Close Outlook
11. Start Outlook. If Outlook displays a dialog-box warning that ThisOutlookSession contains macros and asking if you want to allow them to run, say yes.

Dim objCM As clsCalendarMonitor

Private Sub Application_Quit()
    Set objCM = Nothing
End Sub

Private Sub Application_Startup()
    Set objCM = New clsCalendarMonitor
End Sub

Sub ManualExport()
    objCM.ExportAppointmentsToExcel
End Sub