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

如何提取约会（包括重复约会）？

1 个答案: