请求修改Outlook日历数据提取VBA代码以支持多日历数据获取

没问题！我帮你调整了代码，现在它可以遍历Outlook中所有日历文件夹（包括你标记为绿色的那个），并提取指定日期范围内的约会信息。同时我也修正了原代码里的一些拼写错误和变量名不一致的问题，让代码更规范易读。

修改后的完整代码 #

Sub MeetingExtractAllCalendars()
    Dim outlookApp As Object: Set outlookApp = CreateObject("Outlook.Application")
    Dim myNamespace As Outlook.Namespace
    Dim startDate As Date
    Dim endDate As Date
    Dim rowNum As Long
    Dim myAppointments As Outlook.Items
    Dim currentAppt As Outlook.AppointmentItem
    Dim parentFolder As Outlook.Folder
    Dim calendarFolder As Outlook.Folder
    
    Set myNamespace = outlookApp.GetNamespace("MAPI")
    startDate = Range("E1").Value
    endDate = Range("F1").Value
    
    ' 初始化表头
    Range("A1:D1").Value = Array("Subject", "Start Time", "End Time", "Location")
    rowNum = 2
    
    ' 遍历所有Outlook文件夹，筛选出日历类型的文件夹
    For Each parentFolder In myNamespace.Folders
        ' 检查当前文件夹是否包含子日历文件夹
        For Each calendarFolder In parentFolder.Folders
            If calendarFolder.DefaultItemType = olAppointmentItem Then
                ' 获取当前日历文件夹中的约会项
                Set myAppointments = calendarFolder.Items
                myAppointments.Sort "[Start]"
                myAppointments.IncludeRecurrences = True
                
                ' 筛选指定日期范围内的约会（格式化日期避免系统格式冲突）
                Set currentAppt = myAppointments.Find("[Start] >= """ & Format(startDate, "dd/mm/yyyy hh:mm:ss") & """ And [Start] <= """ & Format(endDate, "dd/mm/yyyy hh:mm:ss") & """")
                
                ' 遍历并写入Excel
                While Not currentAppt Is Nothing
                    Cells(rowNum, 1) = currentAppt.Subject
                    Cells(rowNum, 2) = currentAppt.Start
                    Cells(rowNum, 3) = currentAppt.End
                    Cells(rowNum, 4) = currentAppt.Location
                    rowNum = rowNum + 1
                    Set currentAppt = myAppointments.FindNext
                Wend
            End If
        Next calendarFolder
    Next parentFolder
    
    ' 释放对象，避免内存占用
    Set currentAppt = Nothing
    Set myAppointments = Nothing
    Set calendarFolder = Nothing
    Set parentFolder = Nothing
    Set myNamespace = Nothing
    Set outlookApp = Nothing
    
    MsgBox "所有日历的约会信息提取完成！", vbInformation
End Sub

关键修改说明 #

• 遍历所有日历文件夹：通过myNamespace.Folders遍历Outlook中的所有根文件夹，再逐个检查子文件夹是否为日历类型（DefaultItemType = olAppointmentItem），这样就能覆盖所有自定义日历，包括你标记为绿色的那个。
• 修正变量名和拼写错误：比如原代码里的olfoldercalener改为正确的对象类型判断，统一了日期变量名（原代码中tdystart/tdstart变量名不一致的问题），让代码逻辑更清晰。
• 日期格式化优化：在Find方法中对日期进行格式化，避免因系统日期格式不同导致的筛选失效问题。
• 添加对象释放：最后手动释放所有Outlook对象，避免长期运行导致的内存占用问题。

使用注意事项 #

1. 确保Excel启用了Outlook对象库：打开VBA编辑器 → 工具 → 引用 → 勾选Microsoft Outlook xx.x Object Library（xx.x对应你的Outlook版本）。
2. 日期范围仍通过Excel的E1（开始日期）和F1（结束日期）单元格设置。

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