Question

运行上面的代码后，不显示定期会议。这个问题有解决方案吗？

来自Extracting appointments from shared Outlook calendar to 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.IncludeRecurrences属性设置为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项可以为您完成工作：

将周期性日历会议获取到Excel

1 个答案: