How to get outlook appointments via Excel VBA without listingrecurring appointments

Question

I have a Function that pulls appointments from Outlook, using a date range generated by the user, which then outputs the results in a MSGBox . I would like display scheduled appointments without displaying recurring ones. How can I modify my code to meet my needs?

My date is defined in startDate . Normally this date is defined from a UserForm using a date picker, I have manually entered a date for the purpose of this question.

I have set oAppointments.IncludeRecurrences = False and still get recurring appointments.

CODE

Public Function getOutlookAppointments() As String
    Dim oOutlook              As Object
    Dim oNS                   As Object
    Dim oAppointments         As Object
    Dim oFilterAppointments   As Object
    Dim oAppointmentItem      As Object
    Dim bOutlookOpened        As Boolean
    Dim sfilter               As String
    Dim displayText As String
    Dim startDate As Date
    Const olFolderCalendar = 9

    On Error Resume Next
    Set oOutlook = GetObject(, "Outlook.Application")    'Bind to existing instance of Outlook
    If Err.Number <> 0 Then    'Could not get instance of Outlook, so create a new one
        Err.Clear
        Set oOutlook = CreateObject("Outlook.Application")
        bOutlookOpened = False    'Outlook was not already running, we had to start it
    Else
        bOutlookOpened = True    'Outlook was already running
    End If

    DoEvents

    Set oNS = oOutlook.GetNamespace("MAPI")
    Set oAppointments = oNS.GetDefaultFolder(olFolderCalendar)

    oAppointments.Sort "[Start]"
    oAppointments.IncludeRecurrences = False
    startDate = "07/16/2019"

    sfilter = ("[Start] < """ & Format(startDate, "ddddd h:nn AMPM") & """ and [Start] > """ & Format(startDate + 1, "ddddd h:nn AMPM") & """")
    Set oFilterAppointments = oAppointments.Items.Restrict(sfilter)
    Debug.Print oFilterAppointments.Count & " appointments found."
    'Iterate through each appt in our calendar

    For Each oAppointmentItem In oFilterAppointments
     getOutlookAppointments = getOutlookAppointments & oAppointmentItem.Subject & vbCrLf & oAppointmentItem.start & oAppointmentItem.End


    Next

    MsgBox prompt:=getOutlookAppointments, _
    Title:="Appointments for"


    If bOutlookOpened = False Then    'Since we started Outlook, we should close it now that we're done
        oOutlook.Quit 'There seems to be a delay in this action taking place, but does eventually take place
    End If

Error_Handler_Exit:
    On Error Resume Next
    Set oAppointmentItem = Nothing
    Set oFilterAppointments = Nothing
    Set oAppointments = Nothing
    Set oNS = Nothing
    Set oOutlook = Nothing
    Exit Function


    Resume Error_Handler_Exit

    outlookDates = False
End Function

Answer 1

如果要扩展出现次数，则需要设置Items.IncludeRecurrences属性-请参见https://docs.microsoft.com/zh-cn/office/vba/api/outlook.items.includerecurrences上的示例。

Answer 2

Filtering on a sorted list of occurrences will cause the IncludeRecurrences property not to work as expected. For example, the following sequence will return all appointment occurrences; recurring and non-recurring: (1) Sort by Start property (2) Set property to False (3) call Restrict (ie, filter). See Items.IncludeRecurrences for more information.

    Set oNS = oOutlook.GetNamespace("MAPI")
    Set oAppointments = oNS.GetDefaultFolder(olFolderCalendar)

    startDate = "07/16/2019"

    sfilter = ("[Start] < """ & Format(startDate, "ddddd h:nn AMPM") & """ and [Start] > """ & Format(startDate + 1, "ddddd h:nn AMPM") & """")
    Set oFilterAppointments = oAppointments.Items.Restrict(sfilter)
    Debug.Print oFilterAppointments.Count & " appointments found."

Answer 3

The root of the problem is a missing On Error GoTo 0 to turn off the error bypass On Error Resume Next .

Option Explicit ' Consider this mandatory
' Tools | Options | Editor tab
' Require Variable Declaration
' If desperate declare as Variant


Public Function getOutlookAppointments() As String

    Dim oOutlook              As Object
    Dim oNS                   As Object
    Dim oAppointments         As Object
    Dim oFilterAppointments   As Object
    Dim oAppointmentItem      As Object
    Dim bOutlookOpened        As Boolean
    Dim sfilter               As String
    Dim displayText As String
    Dim startDate As Date
    Const olFolderCalendar = 9
    
    Dim counter As Long
    
    On Error Resume Next
    Set oOutlook = GetObject(, "Outlook.Application")    'Bind to existing instance of Outlook
    If Err.Number <> 0 Then    'Could not get instance of Outlook, so create a new one
        Err.Clear
        Set oOutlook = CreateObject("Outlook.Application")
        bOutlookOpened = False    'Outlook was not already running, we had to start it
    Else
        bOutlookOpened = True    'Outlook was already running
    End If
    
    ' Consider this mandatory as soon as possible after On Error Resume Next
    On Error GoTo 0
    
    DoEvents

    Set oNS = oOutlook.GetNamespace("MAPI")
    
    'Set oAppointments = oNS.GetDefaultFolder(olFolderCalendar)
    ' Error sorting the folder rather than items
    '  was previously bypassed due to missing On Error GoTo 0
    'oAppointments.Sort "[Start]"
    
    Set oAppointments = oNS.GetDefaultFolder(olFolderCalendar).Items    ' <---
    oAppointments.Sort "[Start]"
    
    oAppointments.IncludeRecurrences = True
    
    'startDate = "07/16/2019"
    startDate = Date
    
    'sfilter = ("[Start] < """ & Format(startDate, "ddddd h:nn AMPM") & """ and [Start] > """ & Format(startDate + 1, "ddddd h:nn AMPM") & """")
    sfilter = ("[Start] > """ & Format(startDate, "ddddd h:nn AMPM") & """ and [Start] < """ & Format(startDate + 1, "ddddd h:nn AMPM") & """")
    Debug.Print sfilter
    
    'Set oFilterAppointments = oAppointments.items.Restrict(sfilter)
    Set oFilterAppointments = oAppointments.Restrict(sfilter)
    ' Not useful when .IncludeRecurrences = True
    Debug.Print oFilterAppointments.Count & " appointments found."
    
    'Iterate through each appt in our calendar
    For Each oAppointmentItem In oFilterAppointments
        counter = counter + 1
        getOutlookAppointments = getOutlookAppointments & oAppointmentItem.Subject & " - " & oAppointmentItem.Start & oAppointmentItem.End & vbCrLf
    Next

    Debug.Print counter
    
    MsgBox prompt:=getOutlookAppointments, _
      Title:="Appointments for"
        
    If bOutlookOpened = False Then    'Since we started Outlook, we should close it now that we're done
        oOutlook.Quit 'There seems to be a delay in this action taking place, but does eventually take place
    End If

ExitRoutine:
    Set oAppointmentItem = Nothing
    Set oFilterAppointments = Nothing
    Set oAppointments = Nothing
    Set oNS = Nothing
    Set oOutlook = Nothing
    
End Function