將周期性日歷會議獲取到Excel

Question

運行上面的代碼后，定期會議未顯示。 這個問題有解決方案嗎？

從共享Outlook日歷中提取約會到Excel中的原始代碼

Public Sub ListAppointments()
On Error GoTo ErrHand:

    Application.ScreenUpdating = False

    'This is an enumeration value in context of getDefaultSharedFolder
    Const olFolderCalendar As Byte = 9

    Dim olApp       As Object: Set olApp = CreateObject("Outlook.Application")
    Dim olNS        As Object: Set olNS = olApp.GetNamespace("MAPI")
    Dim olFolder    As Object
    Dim olApt       As Object
    Dim objOwner    As Object: Set objOwner = olNS.CreateRecipient("emailAddressHERE")
    Dim NextRow     As Long
    Dim ws          As Worksheet: Set ws = ThisWorkbook.Sheets("Sheet1")

    objOwner.Resolve

    If objOwner.Resolved Then 
        Set olFolder = olNS.GetSharedDefaultFolder(objOwner, olFolderCalendar)
    end if

    ws.Range("A1:D1").Value2 = Array("Subject", "Start", "End", "Location")

    'Ensure there at least 1 item to continue
    If olFolder.Items.Count = 0 Then Exit Sub

    'Create an array large enough to hold all records
    Dim myArr() As Variant: ReDim myArr(0 To 3, 0 To olFolder.Items.Count - 1)

    'Add the records to an array
    'Add this error skip, as I found some of my calendar items don't have all properties e.g. a start time
    On Error Resume Next
    For Each olApt In olFolder.Items
        myArr(0, NextRow) = olApt.Subject
        myArr(1, NextRow) = olApt.Start
        myArr(2, NextRow) = olApt.End
        myArr(3, NextRow) = olApt.Location
        NextRow = NextRow + 1
    Next
    On Error GoTo 0

    'Write all records to a worksheet from an array, this is much faster
    ws.Range("A2:D" & NextRow + 1).Value = WorksheetFunction.Transpose(myArr)

    'AutoFit
    ws.Columns.AutoFit

cleanExit:
    Application.ScreenUpdating = True
    Exit Sub

ErrHand:
    'Add error handler
    Resume cleanExit
End Sub

該代碼在日歷上顯示了很棒的會議，但是如果有定期會議，則不會顯示。 我需要包括所有會議，甚至重復會議。

Answer 1

如果要獲取定期約會，則必須將Items.IncludeRecurrencess屬性設置為true。

我注意到以下代碼：

'Create an array large enough to hold all records
    Dim myArr() As Variant: ReDim myArr(0 To 3, 0 To olFolder.Items.Count - 1)

在Outlook中，維護數組中的所有項目並不是一個好主意。 如果文件夾包含數千個項目怎么辦？

我建議例如逐月獲取項目。 Items類的Find / FindNext和Restrict項可以為您完成工作：

• 如何：使用Find和FindNext方法檢索Outlook日歷項目
• 如何：在Outlook中使用限制方法來獲取日歷項目