如何提取约会，包括重复？

Question

我想将 Outlook 中的所有约会提取到 Excel 文件中。最终目标是使用这些数据进行时间分析。

我的代码提取了单个实例的会议，但未能提取所有重复会议。

我已经看到了这个问题的几个例子，但是我没有成功地挖掘他们的信息来改进下面的代码。

Option Explicit

Sub RetrieveApts

    Dim olApp As Object
    Dim olNS As Object
    Dim olFolder As Object
    Dim olApt As Object
    Dim oAppointments As Object

    Dim FolderItems As Outlook.Items
    
    Dim NextRow As Long

    Dim FromDate As Date
    Dim ToDate As Date

    Dim pos As Integer

    Application.ScreenUpdating = False' Turns off performance reducing functionality
    Application.CutCopyMode = False' Turns off performance reducing functionality
    
    FromDate = CDate("10/04/2020") 'Hardcoded for now
    ToDate = CDate ("10/09/2020")' Long term these date references will be user set via inputs
    
    On Error Resume Next
    
    Set olApp = GetObject(, "Outlook.Application")'Sets Outlook Reference
    
    If Err.Number > 0 Then Set olApp = CreateObject("Outlook.Application")'Opens Outlook if Outlook was Closed
    
    Set olNS = olApp.GetNameSpace("MAPI")
    Set olFolder = olNS.GetDefaultFolder(9)
   
    NextRow =2
    
    With olFolder.Items
        .Sort "[Start]", True
        .IncludeRecurrences = True
    End With

    With Sheets("Sheet1")
        'Specifies where to store information
        .range("A1:H1").value = _
          Array("Subject","Date","Time Spent", "Location", "Required Attendees", "Optional Attendees", "Categorization", "Body")
    
         For Each olApt In olFolder.Items'Begins Examination of Each Calendar Apt
            'Checks to see if Apt. within date range
            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"
                .cells(NextRow,"D").Value= olApt.Location
                .cells(NextRow,"E").Value= olApt.RequiredAttendees
                .cells(NextRow,"F").Value= olApt.OptionalAttendees
                .cells(NextRow,"G").Value= olApt.Categories
                .cells(NextRow,"H").Value= olApt.Body
            Else
            End IF
        Next olApt
    End With
    
    Set olApt = Nothing
    Set olFolder = Nothing
    Set olNS = Nothing
    Set olApp = Nothing
    
    Application.ScreenUpdating = True
    Application.CutCopyMode = True

End Sub

Answer 1

.Find 用于https://docs.microsoft.com/en-us/office/vba/api/outlook.items.includerecurrences

通常，您可能会迭代整个文件夹或更合理地将项目限制为您想要的项目。该链接表明.Restrict 是不可能的。

Sub RetrieveApts()

    Dim olApp As Object
    Dim olNS As Object
    Dim olFolder As Object
    Dim olApt As Object
    Dim oAppointments As Object

    Dim folderItems As Outlook.Items
    
    Dim NextRow As Long

    Dim FromDate As Date
    Dim ToDate As Date

    Dim pos As Integer
    
    ' Cannot increase performance of broken code
    '  This hides clues, if there are any
    ' Uncomment when code is satisfactory.
    'Application.ScreenUpdating = False ' Turns off performance reducing functionality
    'Application.CutCopyMode = False ' Turns off performance reducing functionality
    
    FromDate = CDate("10/04/2020")
    ToDate = CDate("10/09/2020")
    
    ' This is a rare valid use of
    On Error Resume Next
    '  if turned off when the purpose is served.
    ' Bypass expected error if Outlook is not open
    
    Set olApp = GetObject(, "Outlook.Application") 'Sets Outlook Reference
    If Err.Number > 0 Then Set olApp = CreateObject("Outlook.Application") 'Opens Outlook if Outlook was Closed
    
    ' Return to normal error handling to see unexpected errors
    On Error GoTo 0

    Set olNS = olApp.GetNamespace("MAPI")
    Set olFolder = olNS.GetDefaultFolder(9)
   
    NextRow = 2
    
    Set folderItems = olFolder.Items
    
    With folderItems
        ' https://docs.microsoft.com/en-us/office/vba/api/outlook.items.includerecurrences
        .Sort "[Start]"
        .IncludeRecurrences = True
    End With

    With Sheets("Sheet1")
    
        .Range("A1:H1").Value = Array("Subject", "Date", "Time Spent", "Location", "Required Attendees", "Optional Attendees", "Categorization", "Body")

        Set olApt = folderItems.Find("[Start] >= """ & FromDate & """ and [Start] <= """ & ToDate & """")
    
        While TypeName(olApt) <> "Nothing"
                
            .Cells(NextRow, "A").Value = olApt.Subject
            .Cells(NextRow, "B").Value = CDate(olApt.Start)
            .Cells(NextRow, "B").NumberFormat = "ddd yyyy/mm/dd hh:mm"
                
            .Cells(NextRow, "C").Value = olApt.End - olApt.Start
            .Cells(NextRow, "C").NumberFormat = "HH:MM:SS"
                
            .Cells(NextRow, "D").Value = olApt.Location
            .Cells(NextRow, "E").Value = olApt.RequiredAttendees
                
            .Cells(NextRow, "F").Value = olApt.OptionalAttendees
            .Cells(NextRow, "G").Value = olApt.Categories
                
            .Cells(NextRow, "H").Value = olApt.Body
            
            NextRow = NextRow + 1
    
            Set olApt = folderItems.FindNext
        Wend
        
    End With
                
    ActiveSheet.Columns.AutoFit
    
    Set olApt = Nothing
    Set olFolder = Nothing
    Set olNS = Nothing
    Set olApp = Nothing
    
    Application.ScreenUpdating = True
    Application.CutCopyMode = True
    
    Debug.Print "Done."

End Sub