通过Excel VBA创建带附件的Outlook共享日历约会

我需要在创建Outlook共享日历的约会时自动添加附件，目前使用以下VBA代码创建约会，但不知道如何通过表格单元格中的文件路径给约会添加附件。

原VBA代码 #

Option Explicit
Public Sub CreateOutlookAppointments()
   Sheets("Sheet1").Select
    On Error GoTo Err_Execute
     
    Dim olApp As Outlook.Application
    Dim olAppt As Outlook.AppointmentItem
    Dim blnCreated As Boolean
    Dim olNs As Outlook.Namespace
    Dim CalFolder As Outlook.MAPIFolder
    Dim myRecipient As Outlook.Recipient
    
    Dim i As Long
     
    On Error Resume Next
    Set olApp = Outlook.Application
     
    If olApp Is Nothing Then
        Set olApp = Outlook.Application
         blnCreated = True
        Err.Clear
    Else
        blnCreated = False
    End If
     
    On Error GoTo 0
     
    Set olNs = olApp.GetNamespace("MAPI")
    Set myRecipient = olNs.CreateRecipient("warehouse")
 
    myRecipient.Resolve
 
    If myRecipient.Resolved Then
        Dim CalendarFolder As Outlook.Folder
        Set CalFolder = olNs.GetSharedDefaultFolder(myRecipient, olFolderCalendar)
    End If
    
    i = 2
    Do Until Trim(Cells(i, 1).Value) = ""
     
        Set olAppt = CalFolder.Items.Add(olAppointmentItem)
    
        With olAppt
            'Define calendar item properties
            .Start = Cells(i, 5) + Cells(i, 6)
            .End = Cells(i, 7) + Cells(i, 8)
            .Subject = Cells(i, 1)
            .Location = Cells(i, 2)
            .Body = Cells(i, 3)
            .BusyStatus = olBusy
            .ReminderMinutesBeforeStart = Cells(i, 9)
            .ReminderSet = True
            .Categories = Cells(i, 4)
            .Save
            ' For meetings or Group Calendars
            ' .Send
        End With
                 
        i = i + 1
    Loop
    
    Set olAppt = Nothing
    Set olApp = Nothing
     
    Exit Sub
     
Err_Execute:
    MsgBox "An error occurred - Exporting items to Calendar."
     
End Sub

表格结构（含附件路径列） #

修改后的VBA代码（支持添加附件） #

只需在设置约会属性的代码块中，加入读取附件路径并添加附件的逻辑，同时增加路径有效性检查：

Option Explicit
Public Sub CreateOutlookAppointments()
   Sheets("Sheet1").Select
    On Error GoTo Err_Execute
     
    Dim olApp As Outlook.Application
    Dim olAppt As Outlook.AppointmentItem
    Dim blnCreated As Boolean
    Dim olNs As Outlook.Namespace
    Dim CalFolder As Outlook.MAPIFolder
    Dim myRecipient As Outlook.Recipient
    Dim attachmentPath As String ' 新增：存储附件路径
    
    Dim i As Long
     
    On Error Resume Next
    Set olApp = Outlook.Application
     
    If olApp Is Nothing Then
        Set olApp = Outlook.Application
         blnCreated = True
        Err.Clear
    Else
        blnCreated = False
    End If
     
    On Error GoTo 0
     
    Set olNs = olApp.GetNamespace("MAPI")
    Set myRecipient = olNs.CreateRecipient("warehouse")
 
    myRecipient.Resolve
 
    If myRecipient.Resolved Then
        Dim CalendarFolder As Outlook.Folder
        Set CalFolder = olNs.GetSharedDefaultFolder(myRecipient, olFolderCalendar)
    End If
    
    i = 2
    Do Until Trim(Cells(i, 1).Value) = ""
     
        Set olAppt = CalFolder.Items.Add(olAppointmentItem)
    
        With olAppt
            ' 定义约会属性
            .Start = Cells(i, 5) + Cells(i, 6)
            .End = Cells(i, 7) + Cells(i, 8)
            .Subject = Cells(i, 1)
            .Location = Cells(i, 2)
            .Body = Cells(i, 3)
            .BusyStatus = olBusy
            .ReminderMinutesBeforeStart = Cells(i, 9)
            .ReminderSet = True
            .Categories = Cells(i, 4)
            
            ' 新增：添加附件逻辑
            attachmentPath = Trim(Cells(i, 10).Value)
            If attachmentPath <> "" Then
                ' 检查文件是否存在
                If Dir(attachmentPath) <> "" Then
                    .Attachments.Add attachmentPath
                Else
                    MsgBox "第" & i & "行的附件路径无效：" & attachmentPath, vbExclamation
                End If
            End If
            
            .Save
            ' 若为会议或群组日历，取消注释下方代码
            ' .Send
        End With
                 
        i = i + 1
    Loop
    
    Set olAppt = Nothing
    Set olApp = Nothing
     
    Exit Sub
     
Err_Execute:
    MsgBox "导出日历项时发生错误。"
     
End Sub

关键说明 #

• 附件路径对应表格第10列（Cells(i,10)），若你的列位置不同，需修改数字对应正确列号
• 代码会先检查单元格是否为空，再验证文件路径有效性，避免无效路径导致错误
• 附件需在.Save之前添加，确保附件被保存到约会中

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