如何在不列出重复约会的情况下通过 Excel VBA 获取 Outlook 约会

Question

我有一个函数，它使用用户生成的日期范围从 Outlook 中提取约会，然后将结果输出到MSGBox 。 我想显示预定的约会而不显示重复的约会。 如何修改我的代码以满足我的需求？

我的日期在startDate定义。 通常这个日期是使用日期选择器从用户窗体定义的，我已经手动输入了一个日期来解决这个问题。

我已经设置了oAppointments.IncludeRecurrences = False并且仍然得到定期约会。

代码

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

对出现的事件的排序列表进行筛选将导致IncludeRecurrences属性无法按预期工作。 例如，以下序列将返回所有约会事件； 重复发生和非重复发生：（1）按开始属性排序（2）将属性设置为False（3）调用限制（即过滤器）。 有关更多信息，请参见Items.IncludeRecurrences 。

    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

问题的根源在于缺少On Error GoTo 0以关闭错误绕过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