Continuing on my previous posts: VBA – Extract Outlook Contacts, VBA – Extract Outlook E-mail Messages and VBA – Extract Outlook Tasks, today I thought I demonstrate how to extract Appointment information from Outlook.

'---------------------------------------------------------------------------------------
' Procedure : Outlook_ExtractAppointments
' Author    : Daniel Pineault, CARDA Consultants Inc.
' Website   : http://www.cardaconsultants.com
' Purpose   : Extract Outlook Tasks Listing
' Copyright : The following is release as Attribution-ShareAlike 4.0 International
'             (CC BY-SA 4.0) - https://creativecommons.org/licenses/by-sa/4.0/
' Req'd Refs: Uses Late Binding, so none required
'
' Usage:
' ~~~~~~
' Call Outlook_ExtractAppointments
'
' Revision History:
' Rev       Date(yyyy/mm/dd)        Description
' **************************************************************************************
' 1         2019-07-16              Initial Release
'---------------------------------------------------------------------------------------
Sub Outlook_ExtractAppointments()
    Dim oOutlook              As Object    'Outlook.Application
    Dim oNameSpace            As Object    'Outlook.Namespace
    Dim oFolder               As Object    'Outlook.folder
    Dim oItem                 As Object
    Dim oPrp                  As Object
    Const olFolderCalendar = 9
    Const olAppointment = 26

    On Error Resume Next
    Set oOutlook = GetObject(, "Outlook.Application")        'Bind to existing instance of Outlook
    If Err.Number <> 0 Then        'Could not get instance, so create a new one
        Err.Clear
        Set oOutlook = CreateObject("Outlook.Application")
    End If
    On Error GoTo Error_Handler

    Set oNameSpace = oOutlook.GetNamespace("MAPI")
    Set oFolder = oNameSpace.GetDefaultFolder(olFolderCalendar)
    '    Set oFolder = oOutlook.ActiveExplorer.CurrentFolder    'Process the currently selected folder
    '    Set oFolder = oNameSpace.PickFolder    'Prompt the user to select the folder to process

    On Error Resume Next
    For Each oItem In oFolder.Items
        With oItem
            If .Class = olAppointment Then
                Debug.Print .EntryId, .CreationTime, .Subject, .Start, .end, .duration
                For Each oPrp In .ItemProperties
                    Debug.Print , oPrp.Name, oPrp.Value
                Next oPrp
            End If
        End With
    Next oItem

Error_Handler_Exit:
    On Error Resume Next
    If Not oPrp Is Nothing Then Set oPrp = Nothing
    If Not oItem Is Nothing Then Set oItem = Nothing
    If Not oFolder Is Nothing Then Set oFolder = Nothing
    If Not oNameSpace Is Nothing Then Set oNameSpace = Nothing
    If Not oOutlook Is Nothing Then Set oOutlook = Nothing
    Exit Sub

Error_Handler:
    MsgBox "The following error has occurred" & vbCrLf & vbCrLf & _
           "Error Number: " & Err.Number & vbCrLf & _
           "Error Source: Outlook_ExtractAppointments" & vbCrLf & _
           "Error Description: " & Err.Description & _
           Switch(Erl = 0, "", Erl <> 0, vbCrLf & "Line No: " & Erl) _
           , vbOKOnly + vbCritical, "An Error has Occurred!"
    Resume Error_Handler_Exit
End Sub

As with my other Outlook extraction procedures, I have included 3 different approaches for specifying the folder to extract the Appointments from:

• Use the default task folder
• Use the currently selected folder
• Use the folder picker so the user can select the folder to process

So be sure to use the one that best suit your needs.

Also, do note that this approach can return a large amount of data as it extracts ALL appointments out of the specified folder. You may wish to add a Restrict to filter the data to only get what you are truly after! Refer to my previous post List Outlook Calendar Appointments to see exactly how this can be implemented.