如何修改VBA代码将MS Project任务导出至非默认Outlook日历

原代码通过CreateItem(1)创建约会时，默认存入Outlook的默认日历。要导出到指定非默认日历，核心是直接在目标日历文件夹下创建约会，而非使用全局的CreateItem方法。

关键修改说明 #

• 新增获取Outlook MAPI命名空间的代码，定位到目标日历文件夹
• 替换CreateItem为目标日历文件夹的Items.Add方法创建约会
• 需将代码中的"你的目标日历名称"替换为实际的非默认日历名称

修改后的完整代码 #

Sub Export_Selection_To_OL_Appointments()
    Dim myTask As Task
    Dim myOLApp As Object
    Dim myOLNS As Object
    Dim myCalendarFolder As Object
    Dim myItem As Object
    Const olAppointmentItem As Integer = 1 ' 定义约会项目类型常量
    
    ' 初始化Outlook应用
    On Error Resume Next
    Set myOLApp = CreateObject("Outlook.Application")
    If Err.Number <> 0 Then
        MsgBox "无法启动Outlook应用", vbExclamation
        Exit Sub
    End If
    On Error GoTo 0 ' 恢复正常错误处理
    
    ' 获取Outlook命名空间并定位到指定日历文件夹
    Set myOLNS = myOLApp.GetNamespace("MAPI")
    ' 替换下面的"你的目标日历名称"为实际非默认日历的名称
    Set myCalendarFolder = myOLNS.GetDefaultFolder(9).Parent.Folders("你的目标日历名称") ' olFolderCalendar=9
    If myCalendarFolder Is Nothing Then
        MsgBox "未找到指定的日历文件夹，请检查名称是否正确", vbExclamation
        Exit Sub
    End If
    
    ' 遍历选中任务并创建约会
    For Each myTask In ActiveSelection.Tasks
        Set myItem = myCalendarFolder.Items.Add(olAppointmentItem)
        With myItem
            .Start = myTask.Start
            .End = myTask.Finish
            .Subject = "Rangebank PS " & myTask.Name
            .Categories = myTask.Project
            .Body = myTask.Notes
            .Save
        End With
    Next myTask
    
    MsgBox "任务已成功导出至指定日历", vbInformation
End Sub

额外说明 #

• 如果目标日历不在默认邮件账户下，需调整文件夹定位逻辑，例如：Set myCalendarFolder = myOLNS.Folders("目标账户邮箱").Folders("日历").Folders("你的目标日历名称")
• 代码新增基础错误处理，避免因Outlook未启动或日历不存在导致的崩溃

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