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 InsertModule.
  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 InsertModule
  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
Advertisements

403 comments on “Exporting Appointments from Outlook to Excel

  1. Hi David,

    Thanks for taking the time to reply to me, and sorry for my slow reply. I now have a strange issue where no data is copying to excel, but no error message is presented. The previous script i posted before did work when only using it on one user at a time, but even that isn’t working now. The scripts run, a spreadsheet is created and everything seems to be working in the background, just no data is in the sheets.

    My guess something has changed on either excel or outlook.

    Any suggestions?

    i’m using Office 2016 if this helps.

    Many Thanks
    Jason Burdis

    • Hi, Jason.

      Did you change the list of addresses on line #3? If not, that’s a problem. If you did, then are you certain that you have permission to view the calendars of the people in the list?

    • Hi David,

      line 3 and line 29 edited with the email addresses and correct file path.

      I’ve tried on mailboxes that I have full ownership on, my own, and various shared. It’s strange how its suddenly stopped working,

      This is what happens:

      I double click the file, a box pops up asking if i want to allow the vbs file to run “a program is trying to access your email” i click allow access for 10 minutes.
      The relevant calendars open up quickly, then the file is written to the correct file path and name, but when I open the file its blank. Very strange! 😦

    • Hi, Jason.

      Please try this version and let me know what happens. I added some code to display a dialog-box if the code is unable to access the calendar.

      '--> Define some constants
          'On the next line, edit the list of email addresses of the people who's calendars you want to process
          Const CAL_LIST = "person1@email.com,person2@email.com"
          Const SCRIPT_NAME = "Export Appointments to Excel"
          Const DAYS_TO_INCLUDE = 7
          Const olAppointmentItem = 1
          Const olAppointment = 26
          Const olFolderCalendar = 9
          Const xlCSV = 6
          Const xlCSVWindows = 23
            
      '--> Define some variables
          Dim olkApp, olkSes, olkFld, olkLst, olkApt, olkRes, excApp, excWkb, excWks, lngRow, lngCnt, arrCal, varCal, strFil
        
      '--> Connect to Outlook
          Set olkApp = CreateObject("Outlook.Application")
          Set olkSes = olkApp.GetNamespace("MAPI")
          olkSes.Logon olkApp.DefaultProfileName
       
      '--> Connect to Excel
          Set excApp = CreateObject("Excel.Application")
          excApp.DisplayAlerts = False
          Set excWkb = excApp.Workbooks.Add()
          Set excWks = excWkb.Worksheets(1)
          lngRow = 2
            
      '--> Main routine
          arrCal = Split(CAL_LIST, ",")
          strFil = "E:\office\calendar.csv"
       
          For Each varCal In arrCal
              Set olkFld = GetSharedCalendar(varCal)
              If TypeName(olkFld) = "Nothing" Then
                  Msgbox "Unable to access the calendar at " & varCal, vbInformation+vbOkOnly, SCRIPT_NAME
              Else
                  olkFld.Display
                  If olkFld.DefaultItemType = olAppointmentItem Then
                      Set olkLst = olkFld.Items
                      olkLst.Sort "[Start]"
                      olkLst.IncludeRecurrences = True
                      Set olkRes = olkLst.Restrict("[Start] >= '" & OutlookDateFormat(Now) & "' AND [Start] <= '" & OutlookDateFormat(DateAdd("d", DAYS_TO_INCLUDE, Now)) & "'")
                      '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) = FormatDateTime(olkApt.Start, vbShortDate)
                              excWks.Cells(lngRow, 3) = FormatDateTime(olkApt.End, vbShortDate)
                              excWks.Cells(lngRow, 4) = FormatDateTime(olkApt.Start, vbLongTime)
                              excWks.Cells(lngRow, 5) = FormatDateTime(olkApt.End, vbLongTime)
                              lngRow = lngRow + 1
                              lngCnt = lngCnt + 1
                          End If
                      Next
                  End If
              End If
          Next
           
      '--> Disconnect from Excel
          excWkb.SaveAs strFil, xlCSVWindows
          excWkb.Close
          excApp.DisplayAlerts = True
            
      '--> Disconnect from Outlook
          olkSes.Logoff
            
      '--> Cleanup
          Set excWks = Nothing
          Set excWkb = Nothing
          Set excApp = Nothing
          Set olkApt = Nothing
          Set olkLst = Nothing
          Set olkFld = Nothing
          Set olkSes = Nothing
          Set olkApp = Nothing
            
      '--> End script processing
          WScript.Quit
            
      Function OutlookDateFormat(varDate)
          Dim intHour, strAMPM
          intHour = Hour(varDate)
          If intHour > 12 Then
              intHour = intHour - 12
              strAMPM = "PM"
          Else
              strAMPM = "AM"
          End If
          OutlookDateFormat = Month(varDate) & "/" & Day(varDate) & "/" & Year(varDate) & " " & intHour & ":" & Minute(varDate) & " " & strAMPM
      End Function
       
      Function GetSharedCalendar(strNam)
          Const olFolderCalendar = 9
          Dim olkRec
          Set olkRec = olkSes.CreateRecipient(strNam)
          olkRec.Resolve
          If olkRec.Resolved Then
              Set GetSharedCalendar = olkSes.GetSharedDefaultFolder(olkRec, olFolderCalendar)
          Else
              Set GetSharedCalendar = Nothing
          End If
          Set olkRec = Nothing
      End Function
      
  2. Hi David,

    Your Macro’s are great, i’m looking for something identical to what Laura was needing help with, but to request mutliple emails. Please see my example below.

    Set olkFld = GetSharedCalendar(“person1@email.com”, “person2@email.com”, “person3@email.com”) when i run this, it seems to cause errors.

    in total i need to pull around 40 calendars to reconcile the meetings against our crm system.

    all 40 users are in a distribution list if this makes life easier?

    ‘–&gt; Define some constants
    Const SCRIPT_NAME = “Export Appointments to Excel”
    Const DAYS_TO_INCLUDE = 7
    Const olAppointmentItem = 1
    Const olAppointment = 26
    Const olFolderCalendar = 9
    Const xlCSV = 6
    Const xlCSVWindows = 23
    
    ‘–&gt; Define some variables
    Dim olkApp, olkSes, olkFld, olkLst, olkApt, olkRes, excApp, excWkb, excWks, lngRow, intCnt
    
    ‘–&gt; Connect to Outlook
    Set olkApp = CreateObject(“Outlook.Application”)
    Set olkSes = olkApp.GetNamespace(“MAPI”)
    olkSes.Logon olkApp.DefaultProfileName
    
    ‘–&gt; Main routine
    Set olkFld = GetSharedCalendar(“person1@email.com”, “person2@email.com”, “person3@email.com”)
    If olkFld.DefaultItemType = olAppointmentItem Then
    strFilename = “S:\IT\test.csv”
    Set objItems = olkFld.Items
    If strFilename “” Then
    Set excApp = CreateObject(“Excel.Application”)
    excApp.DisplayAlerts = False
    Set excWkb = excApp.Workbooks.Add()
    Set excWks = excWkb.Worksheets(1)
    lngRow = 2
    Set olkLst = olkFld.Items
    olkLst.Sort “[Start]”
    olkLst.IncludeRecurrences = True
    Set olkRes = olkLst.Restrict(“[Start] &gt;= ‘” &amp; OutlookDateFormat(Now) &amp; “‘ AND [Start] Disconnect from Outlook
    olkSes.Logoff
    
    ‘–&gt; Cleanup
    Set excWks = Nothing
    Set excWkb = Nothing
    Set excApp = Nothing
    Set olkApt = Nothing
    Set olkLst = Nothing
    Set olkFld = Nothing
    Set olkSes = Nothing
    Set olkApp = Nothing
    
    ‘–&gt; End script processing
    WScript.Quit
    
    Function OutlookDateFormat(varDate)
    Dim intHour, strAMPM
    intHour = Hour(varDate)
    If intHour &gt; 12 Then
    intHour = intHour – 12
    strAMPM = “PM”
    Else
    strAMPM = “AM”
    End If
    OutlookDateFormat = Month(varDate) &amp; “/” &amp; Day(varDate) &amp; “/” &amp; Year(varDate) &amp; ” ” &amp; intHour &amp; “:” &amp; Minute(varDate) &amp; ” ” &amp; strAMPM
    End Function
    
    Function GetSharedCalendar(strNam)
    Const olFolderCalendar = 9
    Dim olkRec
    Set olkRec = olkSes.CreateRecipient(strNam)
    olkRec.Resolve
    If olkRec.Resolved Then
    Set GetSharedCalendar = olkSes.GetSharedDefaultFolder(olkRec, olFolderCalendar)
    Else
    Set GetSharedCalendar = Nothing
    End If
    Set olkRec = Nothing
    End Function
    

    Many Thanks in advance
    Jason

    • Hi, Jason.

      Please give this version a try. I don’t have any shared calendars to test with, so there may be bugs.

      '--> Define some constants
          'On the next line, edit the list of email addresses of the people who's calendars you want to process
          Const CAL_LIST = "person1@email.com,person2@email.com"
          Const SCRIPT_NAME = "Export Appointments to Excel"
          Const DAYS_TO_INCLUDE = 7
          Const olAppointmentItem = 1
          Const olAppointment = 26
          Const olFolderCalendar = 9
          Const xlCSV = 6
          Const xlCSVWindows = 23
           
      '--> Define some variables
          Dim olkApp, olkSes, olkFld, olkLst, olkApt, olkRes, excApp, excWkb, excWks, lngRow, lngCnt, arrCal, varCal, strFil
       
      '--> Connect to Outlook
          Set olkApp = CreateObject("Outlook.Application")
          Set olkSes = olkApp.GetNamespace("MAPI")
          olkSes.Logon olkApp.DefaultProfileName
      
      '--> Connect to Excel
          Set excApp = CreateObject("Excel.Application")
          excApp.DisplayAlerts = False
          Set excWkb = excApp.Workbooks.Add()
          Set excWks = excWkb.Worksheets(1)
          lngRow = 2
           
      '--> Main routine
      	arrCal = Split(CAL_LIST, ",")
          strFil = "E:\office\calendar.csv"
      
      	For Each varCal In arrCal
          	Set olkFld = GetSharedCalendar(varCal)
          	If TypeName(olkFld) <> "Nothing" Then
          		olkFld.display
      	    	If olkFld.DefaultItemType = olAppointmentItem Then
      	            Set olkLst = olkFld.Items
      	            olkLst.Sort "[Start]"
      	            olkLst.IncludeRecurrences = True
      	            Set olkRes = olkLst.Restrict("[Start] >= '" & OutlookDateFormat(Now) & "' AND [Start] <= '" & OutlookDateFormat(DateAdd("d", DAYS_TO_INCLUDE, Now)) & "'")
      	            '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) = FormatDateTime(olkApt.Start, vbShortDate)
      	                    excWks.Cells(lngRow, 3) = FormatDateTime(olkApt.End, vbShortDate)
      	                    excWks.Cells(lngRow, 4) = FormatDateTime(olkApt.Start, vbLongTime)
      	                    excWks.Cells(lngRow, 5) = FormatDateTime(olkApt.End, vbLongTime)
      	                    lngRow = lngRow + 1
      	                    lngCnt = lngCnt + 1
      	                End If
      	            Next
      	        End If
      	    End If
          Next
          
      '--> Disconnect from Excel
          excWkb.SaveAs strFil, xlCSVWindows
          excWkb.Close
          excApp.DisplayAlerts = True
           
      '--> Disconnect from Outlook
          olkSes.Logoff
           
      '--> Cleanup
          Set excWks = Nothing
          Set excWkb = Nothing
          Set excApp = Nothing
          Set olkApt = Nothing
          Set olkLst = Nothing
          Set olkFld = Nothing
          Set olkSes = Nothing
          Set olkApp = Nothing
           
      '--> End script processing
          WScript.Quit
           
      Function OutlookDateFormat(varDate)
          Dim intHour, strAMPM
          intHour = Hour(varDate)
          If intHour > 12 Then
              intHour = intHour - 12
              strAMPM = "PM"
          Else
              strAMPM = "AM"
          End If
          OutlookDateFormat = Month(varDate) & "/" & Day(varDate) & "/" & Year(varDate) & " " & intHour & ":" & Minute(varDate) & " " & strAMPM
      End Function
      
      Function GetSharedCalendar(strNam)
      	Const olFolderCalendar = 9
      	Dim olkRec
      	Set olkRec = olkSes.CreateRecipient(strNam)
      	olkRec.Resolve
      	If olkRec.Resolved Then
      		Set GetSharedCalendar = olkSes.GetSharedDefaultFolder(olkRec, olFolderCalendar)
      	Else
      		Set GetSharedCalendar = Nothing
      	End If
      	Set olkRec = Nothing
      End Function
      
  3. Hi David – Do you have code written that would export a range of meetings in an Outlook 2013 calendar with a specific subject as individual ics files?
    Thanks in advance!!!

    • Hi, Nicole.

      This code will save all the selected appointments to .ics files. If you don’t always want to export appointments with the same text in the subject, then I can add code to prompt for text in the subject, then search for and select appointments containing that subject. If you always want to export items with the same text in the subject, then I can modify the code to add a search. It might be faster though to create a view that filters the calendar to just the items you want to export, then use CTRL+A to select them, and run the macro to export them.

      Sub ExportToICS()
          'On the next line edit the path to the folder you want to save the exported appointments to
          Const SAVE_TO_PATH = "c:\users\name\documents\"
          Dim olkApt As Outlook.AppointmentItem
          For Each olkApt In Application.ActiveExplorer.Selection
              olkApt.SaveAs SAVE_TO_PATH & olkApt.Subject & ".ics", olICal
          Next
          Set olkApt = Nothing
      End Sub
      
  4. Hi David,
    These are amazing! I am new to macros, and coding in general (econ major here!). The 2nd revision works perfectly but I am trying to change the code so it doesn’t ask for the date, I would like the date build into the code. For example, just have the macro export every event from today to 30 days out or something along those lines. Like what is in revision 4. I have tried to edit the codes together but have had no luck.

    My final goal is to have 7 separate calendars exporting 30 days worth of calendar data from outlook to excel every Friday. Then this data updates another sheet and organizes it (I actually figured this out somehow). I am trying to automate the process, so the pop-up boxes asking to enter dates, or file locations, or whatnot would mess me up (since nobody would be there to enter the info, and I have no idea even how to start to code that!!) so I am trying to avoid them.

    I hope all of that makes sense. Could you give me some tips or advice?

    • Hi, Dakota.

      Thanks! I’m glad you like them.

      Revision 4 already handles the date range in the way you want. That said, if you want to modify revision 2, then replace these four lines of code

          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"
      

      with

          datBeg = Date
          datEnd = DateAdd("d", 30, datBeg)
      

      This will assign today’s date to datBeg and 30 days from today to datEnd.

    • I apologize for not responding sooner, I never realized that you have commented so quickly! This code worked perfectly of course. However, now the problem I am having is with the calendars exporting. Whenever I put the directory from each calendar separated by a comma, it doesn’t export anything. I have access to all of the calendars from my account, so I thought that would be all I would need. Is that not the case? Do you have any other ideas? I am needing 7 separate persons’ calendars onto one sheet.

    • Hi, Dakota.

      Are you sure the calendar paths are correct? Are the calendars all visible (i.e. show up in your list of calendars when you switch to the calendar view) in Outlook?

    • I believe so, is there varied level of shared access that can be given in outlook? Is there anyway to get around it, or any other options? I am just a bit lost on what I need to do.

    • Hi, Dakota.

      Yes, there are different levels of access. A calendar owner can allow you to only see that they have appointments or they can let you see the details of the appointments. If you can see the details of the appointments in the GUI, then access isn’t the issue.

      Do you see the shared calendars in the list of calendars in Outlook?

  5. THis is great, thank you.
    Is it possible to have a variant that exports other people’s calendars where the person did not share access to their calendar? In effect, I am looking to query coworkers appointments for the sole purpose of finding gaps of availability and do not need appointment details, only date/time start and end times. When I run the above code, I hit the permissions/access restrictions error and hope someone can offer up a “blind” workaround to obtain a list of busy times so I can calculate the negative to fiind the free times.
    Thank you.

    • Hi, Aaron.

      You’re welcome. I’m glad you like the solution.

      Yes, it’s possible to get free/busy times from a calendar without the need for the calendar’s owner to grant access to the calendar. Outlook’s object model offers the FreeBusy method on the Recipient object that does just what you want. It returns a string of characters that denotes free/busy in one minute increments for a given time-frame. How do you want the results laid out in Excel, or do the results need to be in Excel?

    • Thanks again David,
      After further tinkering, I found that removing the .Subject and .Recipients portions of the above code allowed the process to continue without security/permissions restrictions. Populating the results on the Excel file with “Busy” as the subject placeholder, and not requiring the details of recipients almost meets the report needs.

      With additional research, I found a code process to ‘enumerate the number of selected [folders]’. Thinking I was at the home stretch while splicing this new code to ‘report multiple person’s calendars’ to the single excel file from above, I run into the following problem. Using the .DisplayName property I can effectively print the current selected ‘person’s folder’ to the existing ‘category’ field from the above solution; however as the gears move nicely from the enumerate selected folders code, I still have the calendar appointment details ‘frozen’ on the first person’s calendar selected, regardless of the selected group. **This also educated me of Outlook’s limitation of only selecting a max of 30 folders/calendars at a time–different approach used as a solution.

      So the enumerating code utilizes specifically defined variables as “CalendarModule, NavigationGroup, NavigationFolder, and NavigationPane” elements which support the .DisplayName property, but I don’t fully grasp Outlook’s relationship design to properly hook the above code’s Calendar/Folder/Appointment objects as objects so that each person’s calendar correctly advances…. right now the final results of the code displays each person’s name from the NavigationPane/..Folder/..Group but prints the first person’s calendar details repeatedly for each selected person. and when I try to directly tie the olkFld object as the change in folder, I receive the property/method not supported error.

      thank you again for your time and knowledge.

    • Hi, Aaron.

      Id have to see the code you’re using in order to offer specific suggestions on how to fix the problem you’re encountered.

  6. Dear David,

    Thank you so much for your sharing and help. I’ve been studying your codes practicing and learning VBA. While I play with different versions of this exporting appointments trick, I created a simple scenario, is like, after the appointment list in full detail is exported, there’s another excel with another set of code, to search full the appointment list, look for a set of matches then according to the result it will gather data reference to the match and export to different CSV in different file locations. e.g. The script looking at the appointment list’s “location” column, then if result match location A, the appointment’s start time, end time, host and location these info go into folder A’s CSV file. I’ve taken example of above conversation of you and another reader, about searching and editing for exact match data in cell. I’d love to, at your most convenience, be advised by you, or maybe look at some examples in next post. Looking forward to your feedback. Cheers 🙂

    • Hi, EvWong.

      You’re welcome!

      Sorry, but I’m not clear on what it is you want feedback on. Are you asking if what you outlined is possible, are you asking how to do it, or something else?

    • Hi, MJ.

      Yes, it’s possible to extract a meeting’s participants from an Outlook meeting and write them to Excel. It’s more difficult though to do that from a meeting saved to disk in .msg format. The reason for this is that Microsoft hasn’t provided a way to read the saved item back into Outlook. To do that, we have to turn to a third-party Outlook utility called Outlook Redemption. If you can use Redemption in your environment, then I can show you how to do this. If not, then there is no good solution.

  7. Hey David,

    first of all Thanks for the code!
    We are currently using this code:

    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 = “E:\office\calendar.csv”

    If strFilename “” Then

    Set excApp = CreateObject(“Excel.Application”)
    excApp.DisplayAlerts = False
    Set excWkb = excApp.Workbooks.Add()
    Set excWks = excWkb.Worksheets(1)
    ‘Write Excel Column Headers
    With excWks

    .Cells(1, 1) = “Subject”
    .Cells(1, 2) = “Start”
    .Cells(1, 3) = “End”

    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.Subject
    excWks.Cells(lngRow, 2) = olkApt.Start
    excWks.Cells(lngRow, 3) = olkApt.End

    lngRow = lngRow + 1
    intCnt = intCnt + 1
    End If
    Next
    excWks.Columns(“A:C”).AutoFit
    ‘Set excWkb = excApp.ActiveWorkbook
    excWkb.SaveAs strFilename
    excApp.DisplayAlerts = True
    End If

    End If
    Set excWks = Nothing
    Set excWkb = Nothing
    Set excApp = Nothing
    Set olkApt = Nothing
    Set olkLst = Nothing
    Set olkFld = Nothing
    End Sub

    and are facing 2 problems we can’t seem to fix.

    First of all (which should be really easy….) we want to create a CSV-file, which we thought should work by adding , xlCSV to the line “excWkb.SaveAs strFilename”, but it doesn’t seem to work. Do you have any suggestions?

    Second of all, we want to start the code repeadetly without the user having to start it manually. So it should run every 15 minutes by itself. Do you know how to do that?

    Help would be very much appreciated.

    Thanks a lot in advance,
    Laura

    • Hi, Laura.

      You’re welcome!

      It is as easy as adding xlCSV, but you also have to tell Outlook what “xlCSV” means. To do that you must either include a reference to Excel or define a constant. The latter is easier. Add

      Const xlCSV = 6
      

      at the top of the code just below the other “Const” definition. You can then modify the SaveAs line accordingly.

      Outlook doesn’t have a built-in mechanism for scheduling a macro to run at specific times or set intervals. There are ways of accomplishing that, but the best solution is to convert this code into VBscript and then schedule it using Windows’ built in Task Scheduler. If you want to go that route, then I’ll be happy to convert the code to VBscript for you.

    • Hi David,

      Thanks so much for your fast reply! We knew we were missing something really easy and basic but couldn’t find out what it was.. So thanks a lot!

      It would be great if you could convert the code into VBscript so we could use the Task Scheduler. Here’s the code again:

      Sub ExportAppointmentsToExcel()
      Const SCRIPT_NAME = “Export Appointments to Excel”
      Const xlCSV = 6
      Dim olkFld As Object, _
      olkLst As Object, _
      olkApt As Object, _
      olkRes 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 = “E:\office\calendar.csv”

      Set objItems = olkFld.Items

      If strFilename “” Then

      Set excApp = CreateObject(“Excel.Application”)
      excApp.DisplayAlerts = False
      Set excWkb = excApp.Workbooks.Add()
      Set excWks = excWkb.Worksheets(1)

      lngRow = 2
      Set olkLst = olkFld.Items
      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 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.Subject
      excWks.Cells(lngRow, 2) = VBA.Format(olkApt.Start, "Short Date")
      excWks.Cells(lngRow, 3) = VBA.Format(olkApt.End, "Short Date")
      excWks.Cells(lngRow, 4) = VBA.Format(olkApt.Start, "Long Time")
      excWks.Cells(lngRow, 5) = VBA.Format(olkApt.End, "Long Time")

      lngRow = lngRow + 1
      intCnt = intCnt + 1
      End If
      Next
      excWks.Columns("A:E").AutoFit
      excWkb.SaveAs strFilename, xlCSV
      excWkb.Close
      excApp.DisplayAlerts = True
      End If

      End If
      Set excWks = Nothing
      Set excWkb = Nothing
      Set excApp = Nothing
      Set olkApt = Nothing
      Set olkLst = Nothing
      Set olkFld = Nothing
      End Sub

      Thanks in advance! You should seriously consider a "Donate coffee" button as a Thank you 😉

      Best regards
      Laura

    • Hi, Laura.

      This should do it. This will export the next 7 days of appointments. If you want to export a different number of days, then edit the value of the DAYS_TO_INCLUDE constant at the top of the script. To use this

      1. Open Notepad
      2. Copy the code below and paste it into Notepad
      3. Save the file with a .vbs extension

      You can then place the script on all the computers you want to run it on. On each of those computers you will then create a scheduled task using Windows Task Scheduler that runs the script.

      '--> Define some constants
      	Const SCRIPT_NAME = "Export Appointments to Excel"
      	Const DAYS_TO_INCLUDE = 7
      	Const olAppointmentItem = 1
      	Const olAppointment = 26
      	Const olFolderCalendar = 9
      	Const xlCSV = 6
      	Const xlCSVWindows = 23
      	
      '--> Define some variables
      	Dim olkApp, olkSes, olkFld, olkLst, olkApt, olkRes, excApp, excWkb, excWks, lngRow, intCnt
      
      '--> Connect to Outlook
      	Set olkApp = CreateObject("Outlook.Application")
      	Set olkSes = olkApp.GetNamespace("MAPI")
      	olkSes.Logon olkApp.DefaultProfileName
      	
      '--> Main routine
      	Set olkFld = olkSes.GetDefaultFolder(olFolderCalendar)
      	If olkFld.DefaultItemType = olAppointmentItem Then
      		strFilename = "E:\office\calendar.csv"
      		Set objItems = olkFld.Items
      		If strFilename <> "" Then
      			Set excApp = CreateObject("Excel.Application")
      			excApp.DisplayAlerts = False
      			Set excWkb = excApp.Workbooks.Add()
      			Set excWks = excWkb.Worksheets(1)
      			lngRow = 2
      			Set olkLst = olkFld.Items
      			olkLst.Sort "[Start]"
      			olkLst.IncludeRecurrences = True
      			Set olkRes = olkLst.Restrict("[Start] >= '" & OutlookDateFormat(Now) & "' AND [Start] <= '" & OutlookDateFormat(DateAdd("d", DAYS_TO_INCLUDE, Now)) & "'")
      			'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) = FormatDateTime(olkApt.Start, vbShortDate)
      					excWks.Cells(lngRow, 3) = FormatDateTime(olkApt.End, vbShortDate)
      					excWks.Cells(lngRow, 4) = FormatDateTime(olkApt.Start, vbLongTime)
      					excWks.Cells(lngRow, 5) = FormatDateTime(olkApt.End, vbLongTime)
      					lngRow = lngRow + 1
      					intCnt = intCnt + 1
      				End If
      			Next
      			excWkb.SaveAs strFilename, xlCSVWindows
      			excWkb.Close
      			excApp.DisplayAlerts = True
      		End If
      	End If
      	
      '--> Disconnect from Outlook
      	olkSes.Logoff
      	
      '--> Cleanup
      	Set excWks = Nothing
      	Set excWkb = Nothing
      	Set excApp = Nothing
      	Set olkApt = Nothing
      	Set olkLst = Nothing
      	Set olkFld = Nothing
      	Set olkSes = Nothing
      	Set olkApp = Nothing
      	
      '--> End script processing
      	WScript.Quit
      	
      Function OutlookDateFormat(varDate)
          Dim intHour, strAMPM
          intHour = Hour(varDate)
          If intHour > 12 Then
              intHour = intHour - 12
              strAMPM = "PM"
          Else
              strAMPM = "AM"
          End If
          OutlookDateFormat = Month(varDate) & "/" & Day(varDate) & "/" & Year(varDate) & " " & intHour & ":" & Minute(varDate) & " " & strAMPM
      End Function
      
    • Hi David,

      thanks again! Just one more problem:

      The calendar we want to export into excel is not the default calendar from the person logged on into the session, but a shared calendar we added to the profile.
      We tried to change the code into getting the currently selected/active folder but couldn’t get it to work. Is there any possibility to do that?

      Thanks in advance,
      greetings from Germany,
      Laura

    • Good morning, Laura.

      You’re welcome.

      Yes, we can modify the code to use a shared calendar instead of the default calendar. You don’t want to use the currently selected folder though since that would require the logged in person to know when the script was about to run and select the correct folder. Instead, we can add some code that uses the correct calendar every time without requiring the logged in person to take any action. Will each logged in person be using the same calendar or will they each be using a different calendar?

    • Good morning David,

      thanks again for your quick response!

      There will only be one person logged in and they will always be using the same shared calendar.

      Thanks and kind regards,
      Laura

    • Hi, Laura.

      Add this function to the bottom of the code you already have.

      Function GetSharedCalendar(strNam)
          Const olFolderCalendar = 9
          Dim olkRec
          Set olkRec = olkSes.CreateRecipient(strNam)
          olkRec.Resolve
          If olkRec.Resolved Then
              Set GetSharedCalendar = olkSes.GetSharedDefaultFolder(olkRec, olFolderCalendar)
          Else
              Set GetSharedCalendar = Nothing
          End If
          Set olkRec = Nothing
      End Function
      

      Now, change line 19 of the code from

      Set olkFld = olkSes.GetDefaultFolder(olFolderCalendar)
      

      to

      Set olkFld = GetSharedCalendar("address@company.com")
      

      replacing “address@company.com” with the email address of the mailbox containing the shared calendar.

Leave a Reply

Fill in your details below or click an icon to log in:

WordPress.com Logo

You are commenting using your WordPress.com account. Log Out / Change )

Twitter picture

You are commenting using your Twitter account. Log Out / Change )

Facebook photo

You are commenting using your Facebook account. Log Out / Change )

Google+ photo

You are commenting using your Google+ account. Log Out / Change )

Connecting to %s