Excel VBA向Outlook指定日历文件夹创建约会报运行时错误5

使用Excel VBA编写脚本向Outlook指定日历文件夹创建约会（用于指定约会所属的目标账号），运行时触发运行时错误'5'：无效的过程调用或参数，报错位置为代码行：
Set OutlookAppt = objfolder.Items.Add(olAppointmentItem)
原实现代码：

Sub AddAppointments()

    Dim LastRow As Long
    Dim I As Long
    Dim xRg As Range
    Dim myNamespace As Object
    Dim myRecipient As Object
    Dim objfolder As Object
    Dim OutlookAppt As Object 

    Set OutApp = GetObject(, "Outlook.Application")
        If ErrL <> 0 Then
            Set oApp = CreateObject("Outlook.Application")
        End If
 
    Set myNamespace = OutApp.GetNamespace("MAPI")
    Set objfolder = myNamespace.PickFolder 'lets user pick folder where appt will be created
 
    Set xRg = Range("A2:G2")
        LastRow = Range("A" & Rows.Count).End(xlUp).Row
        For I = 1 To (LastRow - 1)
            If LCase(Trim(xRg.Cells(I, 8).Value)) <> "yes" Then
                Set OutlookAppt = oApp.CreateItem(1)
                OutlookAppt.Subject = xRg.Cells(I, 1).Value
                OutlookAppt.Location = xRg.Cells(I, 2).Value
                OutlookAppt.Start = xRg.Cells(I, 3).Value
                OutlookAppt.Duration = xRg.Cells(I, 4).Value
                xRg.Cells(I, 8).Value = "Yes"
                If Trim(xRg.Cells(I, 5).Value) = "" Then
                    OutlookAppt.BusyStatus = 2
                Else
                    OutlookAppt.BusyStatus = xRg.Cells(I, 5).Value
                End If
                If xRg.Cells(I, 6).Value > 0 Then
                    OutlookAppt.ReminderSet = True
                    OutlookAppt.ReminderMinutesBeforeStart = xRg.Cells(I, 6).Value
                Else
                    OutlookAppt.ReminderSet = False
                End If
                OutlookAppt.Body = xRg.Cells(I, 7).Value
            End If

            Set OutlookAppt = objfolder.Items.Add(olAppointmentItem)

        Next       
    Set OutlookAppt = Nothing
End Sub

• 晚绑定调用Outlook时未手动定义内置常量olAppointmentItem，该常量实际值为1，未定义时运行时值为Empty，传入Items.Add方法直接触发参数无效错误，这是报错的核心诱因
• 代码存在基础语法/变量错误：Outlook应用对象变量名混用（OutApp/oApp）、错误判断变量写错（不存在ErrL属性，正确应为Err.Number）
• 业务逻辑错误：原代码先在默认日历创建约会并填充属性，之后才在目标文件夹新建空白约会，已填充的属性不会同步到目标约会；且缺少Save方法调用，约会创建后不会实际保存
• 缺少合法性校验：未判断用户是否取消文件夹选择、选中的文件夹是否为日历类型，若选中邮件/联系人等非日历文件夹，创建约会也会触发参数错误

Sub AddAppointments()
    ' 晚绑定场景手动定义Outlook常量
    Const olAppointmentItem As Long = 1
    
    Dim LastRow As Long
    Dim I As Long
    Dim xRg As Range
    Dim myNamespace As Object
    Dim objfolder As Object
    Dim OutlookAppt As Object
    Dim OutApp As Object

    ' 兼容Outlook未启动的场景
    On Error Resume Next
    Set OutApp = GetObject(, "Outlook.Application")
    If Err.Number <> 0 Then
        Set OutApp = CreateObject("Outlook.Application")
    End If
    On Error GoTo 0
 
    Set myNamespace = OutApp.GetNamespace("MAPI")
    Set objfolder = myNamespace.PickFolder
    
    ' 处理用户取消选择的情况
    If objfolder Is Nothing Then
        MsgBox "未选择目标文件夹，程序退出"
        Exit Sub
    End If
    
    ' 校验选中文件夹是否支持创建约会
    If objfolder.DefaultItemType <> olAppointmentItem Then
        MsgBox "选中的文件夹不是日历类型，无法创建约会，请重新运行选择", vbExclamation
        Exit Sub
    End If
 
    Set xRg = Range("A2:G2")
    LastRow = Range("A" & Rows.Count).End(xlUp).Row
    For I = 1 To (LastRow - 1)
        If LCase(Trim(xRg.Cells(I, 8).Value)) <> "yes" Then
            ' 直接在目标日历文件夹创建约会
            Set OutlookAppt = objfolder.Items.Add(olAppointmentItem)
            ' 填充约会属性
            OutlookAppt.Subject = xRg.Cells(I, 1).Value
            OutlookAppt.Location = xRg.Cells(I, 2).Value
            OutlookAppt.Start = xRg.Cells(I, 3).Value
            OutlookAppt.Duration = xRg.Cells(I, 4).Value
            If Trim(xRg.Cells(I, 5).Value) = "" Then
                OutlookAppt.BusyStatus = 2
            Else
                OutlookAppt.BusyStatus = xRg.Cells(I, 5).Value
            End If
            If xRg.Cells(I, 6).Value > 0 Then
                OutlookAppt.ReminderSet = True
                OutlookAppt.ReminderMinutesBeforeStart = xRg.Cells(I, 6).Value
            Else
                OutlookAppt.ReminderSet = False
            End If
            OutlookAppt.Body = xRg.Cells(I, 7).Value
            ' 保存约会
            OutlookAppt.Save
            xRg.Cells(I, 8).Value = "Yes"
        End If
    Next
    
    ' 释放对象
    Set OutlookAppt = Nothing
    Set objfolder = Nothing
    Set myNamespace = Nothing
    Set OutApp = Nothing
    MsgBox "所有约会已创建完成"
End Sub

• 手动定义晚绑定场景下的Outlook常量，解决参数传递错误
• 统一变量命名，修正错误捕获逻辑，兼容Outlook未启动的运行环境
• 调整创建约会的流程，直接在目标文件夹生成约会项，填充属性后调用Save方法完成持久化
• 增加边界场景校验，避免用户误操作导致的运行错误

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