时间戳

首页 > 解决方案 > 将定期日历会议转换为 Excel

excel - 将定期日历会议转换为 Excel

问题描述

运行上述代码后未显示定期会议。这个问题有什么解决办法吗？

从共享 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

该代码在日历上显示了很棒的会议，但是如果有定期会议，它就不会显示。我需要包括所有会议，甚至是重复的会议。

标签： excelvbaoutlook

解决方案

如果要获得定期约会，则必须将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 项目为您工作：

推荐阅读