如何提取約會，包括重復？

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