使用VBA导出Outlook日历至Excel时缺失他人创建的定期会议

问题描述 #

我查阅了相关历史问题，但仍遇到一个难题：使用VBA将Outlook日历导出到Excel时，他人创建的定期会议会缺失。我通过输入框限制了日期范围，IncludeRecurrences对我自行创建的「Appointment」类型条目有效，代码也能正确提取我和他人创建的非定期「Meetings」或「Teams meetings」。我遗漏了什么？除了olApt，是否需要包含其他类型？

原代码如下：

Option Explicit

Sub ListAppointments()
    Dim olApp As Object
    Dim olNS As Object
    Dim olFolder As Object
    Dim olApt As Object
    Dim olItems As Object
    Dim NextRow As Long
    Dim FromDate As Date
    Dim ToDate As Date

    FromDate = Format(InputBox("Enter Start Date", , Date), "dd/mm/yyyy")
    ToDate = Format(InputBox("Enter End Date", , Date), "dd/mm/yyyy")

    On Error Resume Next
    Set olApp = GetObject(, "Outlook.Application")
    If Err.Number > 0 Then Set olApp = CreateObject("Outlook.Application")
    On Error GoTo 0

    Set olNS = olApp.GetNamespace("MAPI")
    Set olFolder = olNS.GetDefaultFolder(9) 'olFolderCalendar
    Set olItems = olFolder.Items
    NextRow = 3
    
    olItems.Sort "[Start]"
    olItems.IncludeRecurrences = True

    With Sheets("Sheet1") 'Change the name of the sheet here
        .Range("A2:C2").Value = Array("Subject", "Date", "Total Time")
        For Each olApt In olFolder.Items
            If (olApt.Start >= FromDate And olApt.Start <= ToDate) Then
                .Cells(NextRow, "A").Value = olApt.Subject
                .Cells(NextRow, "B").Value = CDate(olApt.Start)
                .Cells(NextRow, "C").Value = olApt.End - olApt.Start
                .Cells(NextRow, "C").NumberFormat = "HH:MM:SS"
                NextRow = NextRow + 1
            Else
            End If
        Next olApt
        .Columns.AutoFit
    End With

    Set olApt = Nothing
    Set olFolder = Nothing
    Set olNS = Nothing
    Set olApp = Nothing
End Sub

解决方案 #

已解决！添加Find/FindNext方法是正确的解决方案，修改后的代码片段如下：

olItems.Sort "[Start]"
olItems.IncludeRecurrences = True
Set currentAppointment = olItems.Find("[Start] >= """ & FromDate & """ and [Start] <= """ & ToDate & """")

With Sheets("Sheet1") 'Change the name of the sheet here
    .Range("A2:C2").Value = Array("Subject", "Date", "Total Time")
    For Each currentAppointment In olItems
        If (currentAppointment.Start >= FromDate And currentAppointment.Start <= ToDate) Then
            .Cells(NextRow, "A").Value = currentAppointment.Subject
            .Cells(NextRow, "B").Value = CDate(currentAppointment.Start)
            .Cells(NextRow, "C").Value = currentAppointment.End - currentAppointment.Start
            .Cells(NextRow, "C").NumberFormat = "HH:MM:SS"
            NextRow = NextRow + 1
            Set currentAppointment = olItems.FindNext
        Else
        End If
    Next currentAppointment
End With

内容的提问来源于stack exchange，提问作者kary