Excel导出日期至Outlook日历报错：获取指定日历代码行异常求助

问题描述 #

执行以下代码行时出现错误，无法正确获取指定的Outlook日历：

'Get the calendar by name
Set OutlookCalendar = OutlookApp.Session.Folders("Calendar Name").Folders(CalendarName)

完整VBA代码如下：

Sub ExportToOutlook()

    Dim OutlookApp As Outlook.Application
    Dim OutlookCalendar As Outlook.Folder
    Dim OutlookEvent As Outlook.AppointmentItem
    Dim StartDate As Date
    Dim EndDate As Date
    Dim EventTitle As String
    Dim EventDescription As String
    Dim EventLocation As String
    Dim CalendarName As String
    Dim tbl As ListObject
    Dim LastRow As Long
    Dim i As Long
    Dim CalendarNameCell As String
    Dim EventTitleCell As String
    Dim EventDescriptionCell As String
    Dim EventLocationCell As String
    
    'Name of the table
    Set tbl = ThisWorkbook.Sheets("Pris nightliner").ListObjects("Runde1")
    LastRow = tbl.Range.Rows.Count

    'Cell that contains the calendar name
    CalendarNameCell = "H13"

    'Cell that contains the event title
    EventTitleCell = "H9"

    'Cell that contains the event description
    EventDescriptionCell = "H12"

    'Cell that contains the event location
    EventLocationCell = "F2"

    'Create an instance of Outlook
    Set OutlookApp = CreateObject("Outlook.Application")

    'Get the calendar name
    CalendarName = ThisWorkbook.Sheets("Pris nightliner").Range(CalendarNameCell).Value

    'Get the calendar by name
    Set OutlookCalendar = OutlookApp.Session.Folders("Calendar Name").Folders(CalendarName)

    'Get the first and last date
    StartDate = tbl.ListColumns("Start Date").DataBodyRange(2).Value
    EndDate = tbl.ListColumns("Start Date").DataBodyRange(LastRow).Value

    'Get the event title, location, and description
    EventTitle = ThisWorkbook.Sheets("Pris nightliner").Range(EventTitleCell).Value
    EventDescription = ThisWorkbook.Sheets("Pris nightliner").Range(EventDescriptionCell).Value
    EventLocation = ThisWorkbook.Sheets("Pris nightliner").Range(EventLocationCell).Value

    'Create a new event in Outlook
    Set OutlookEvent = OutlookApp.CreateItem(olAppointmentItem)
    With OutlookEvent
        .Start = StartDate
        .End = EndDate
        .Subject = EventTitle
        .Location = EventLocation
        .Body = EventDescription
        .Save
        .Move OutlookCalendar
    End With

    'Release the Outlook objects
    Set OutlookEvent = Nothing
    Set OutlookCalendar = Nothing
    Set OutlookApp = Nothing
End Sub

错误原因及修复方案 #

1. 核心错误：硬编码的无效文件夹路径 #

OutlookApp.Session.Folders("Calendar Name")中的"Calendar Name"是无效硬编码值。Outlook的Session.Folders集合下首先是邮箱账户/数据文件，而非直接的日历文件夹，必须替换为实际的账户标识（邮箱地址或账户显示名称）。

2. 修复方案一：获取默认日历 #

如果目标是默认日历，直接使用Outlook内置方法获取，无需指定账户：

' 替换原错误代码行
Set OutlookCalendar = OutlookApp.Session.GetDefaultFolder(olFolderCalendar)

3. 修复方案二：获取自定义名称的日历 #

如果要获取非默认的自定义日历，需先定位到对应的账户，再查找日历文件夹：

' 替换原错误代码行
Dim accountName As String
' 替换为你的Outlook邮箱地址，比如"yourname@example.com"
accountName = "your_email@domain.com"
Set OutlookCalendar = OutlookApp.Session.Folders(accountName).Folders(CalendarName)

若不确定账户名称，可遍历所有账户自动查找：

' 替换原错误代码行
Dim ns As Outlook.NameSpace
Dim acc As Outlook.Account
Dim targetFolder As Outlook.Folder
Set ns = OutlookApp.Session

For Each acc In ns.Accounts
    On Error Resume Next
    Set targetFolder = acc.Session.Folders(acc.DisplayName).Folders(CalendarName)
    On Error GoTo 0
    If Not targetFolder Is Nothing Then
        Set OutlookCalendar = targetFolder
        Exit For
    End If
Next acc

4. 额外注意事项 #

• 确保CalendarName变量的值与Outlook中实际日历名称完全一致（大小写敏感）
• 提前添加Outlook对象库引用：依次点击VBA编辑器的「工具」→「引用」，勾选「Microsoft Outlook xx.x Object Library」，避免olFolderCalendar等常量未定义的错误
• 添加空值判断：若CalendarName为空，需提前处理，避免运行时错误

内容的提问来源于stack exchange，提问作者Michael Thøgersen