如何修改VBA代码导出Outlook日历中的周期性会议/约会？

核心思路 #

普通约会可直接遍历获取，但周期性会议仅靠主条目无法拿到具体实例，必须通过GetRecurrencePattern()生成指定时间范围内的所有重复实例，再逐一导出。

修改后的完整代码 #

Sub ExportCalendarWithRecurrences()
    Dim olApp As Outlook.Application
    Dim olNamespace As Outlook.Namespace
    Dim olFolder As Outlook.Folder
    Dim olItems As Outlook.Items
    Dim olItem As Object
    Dim recPattern As Outlook.RecurrencePattern
    Dim recItems As Outlook.Items
    Dim recItem As Object
    Dim startDate As Date
    Dim endDate As Date
    Dim excelApp As Object
    Dim excelWB As Object
    Dim excelWS As Object
    Dim rowNum As Integer
    
    ' 设置导出的时间范围：当前周的周一至周日
    startDate = DateSerial(Year(Date), Month(Date), Day(Date) - Weekday(Date, vbMonday) + 1)
    endDate = startDate + 6
    
    ' 初始化Outlook对象
    Set olApp = New Outlook.Application
    Set olNamespace = olApp.GetNamespace("MAPI")
    Set olFolder = olNamespace.GetDefaultFolder(olFolderCalendar)
    Set olItems = olFolder.Items
    olItems.Sort "[Start]", True ' 按开始时间升序排序
    
    ' 初始化Excel对象
    Set excelApp = CreateObject("Excel.Application")
    excelApp.Visible = True
    Set excelWB = excelApp.Workbooks.Add
    Set excelWS = excelWB.Sheets(1)
    
    ' 写入表头
    rowNum = 1
    excelWS.Cells(rowNum, 1).Value = "主题"
    excelWS.Cells(rowNum, 2).Value = "开始时间"
    excelWS.Cells(rowNum, 3).Value = "结束时间"
    excelWS.Cells(rowNum, 4).Value = "位置"
    excelWS.Cells(rowNum, 5).Value = "是否周期性"
    excelWS.Cells(rowNum, 6).Value = "实例类型"
    
    ' 遍历日历条目
    For Each olItem In olItems
        ' 只处理约会/会议，排除其他类型
        If olItem.Class = olAppointment Then
            ' 判断是否为周期性条目
            If olItem.IsRecurring Then
                Set recPattern = olItem.GetRecurrencePattern()
                ' 获取指定时间范围内的所有重复实例
                Set recItems = recPattern.GetOccurrences(startDate, endDate)
                
                ' 遍历每个重复实例
                For Each recItem In recItems
                    rowNum = rowNum + 1
                    excelWS.Cells(rowNum, 1).Value = recItem.Subject
                    excelWS.Cells(rowNum, 2).Value = recItem.Start
                    excelWS.Cells(rowNum, 3).Value = recItem.End
                    excelWS.Cells(rowNum, 4).Value = recItem.Location
                    excelWS.Cells(rowNum, 5).Value = "是"
                    excelWS.Cells(rowNum, 6).Value = "周期性实例"
                Next recItem
            Else
                ' 处理普通约会，判断是否在指定周范围内
                If (olItem.Start >= startDate And olItem.Start <= endDate + #11:59:59 PM#) Then
                    rowNum = rowNum + 1
                    excelWS.Cells(rowNum, 1).Value = olItem.Subject
                    excelWS.Cells(rowNum, 2).Value = olItem.Start
                    excelWS.Cells(rowNum, 3).Value = olItem.End
                    excelWS.Cells(rowNum, 4).Value = olItem.Location
                    excelWS.Cells(rowNum, 5).Value = "否"
                    excelWS.Cells(rowNum, 6).Value = "普通约会"
                End If
            End If
        End If
    Next olItem
    
    ' 调整Excel列宽
    excelWS.Columns.AutoFit
    
    ' 释放对象
    Set recItem = Nothing
    Set recItems = Nothing
    Set recPattern = Nothing
    Set olItem = Nothing
    Set olItems = Nothing
    Set olFolder = Nothing
    Set olNamespace = Nothing
    Set olApp = Nothing
    Set excelWS = Nothing
    Set excelWB = Nothing
    Set excelApp = Nothing
    
    MsgBox "导出完成，共导出 " & rowNum - 1 & " 条条目", vbInformation
End Sub

关键代码说明 #

1. 时间范围设置：通过DateSerial和Weekday函数自动计算当前周的周一（vbMonday表示周一为一周起始）到周日，也可手动替换为指定日期：

   startDate = #2024/5/13# ' 指定起始日期
   endDate = #2024/5/19# ' 指定结束日期
   

2. 周期性实例获取：recPattern.GetOccurrences(startDate, endDate)会自动生成该时间段内所有有效的重复会议实例，包括调整过的例外实例（比如某一次周期性会议被修改时间）。
3. 条目过滤：通过olItem.Class = olAppointment确保只处理约会/会议类型，避免遍历到日历中的其他对象。
4. 普通约会范围判断：用olItem.Start >= startDate And olItem.Start <= endDate + #11:59:59 PM#确保包含周日当天的所有约会。

使用注意事项 #

• 运行前需在Outlook中启用宏（文件>选项>信任中心>信任中心设置>宏设置>启用所有宏，仅测试时建议，日常使用可选“启用签署的宏”）。
• 若导出范围包含过去的时间，需确保Outlook中未清理旧的周期性会议主条目。

内容的提问来源于stack exchange，提问作者Maluc