如何在 Outlook 中將行事曆逐一傳送給多位收件者？

一般情況下，您可以透過 Outlook 的以電子郵件傳送行事曆功能，快速又輕鬆地將行事曆傳送給單一收件者。但若您希望以 iCalendar 檔案形式，將行事曆逐一附加並傳送給多位聯絡人，就必須逐筆操作。本文將為您介紹一種簡單有效的方法，助您在 Outlook 中輕鬆完成多筆行事曆的個別傳送！

使用 VBA 程式碼將行事曆逐一傳送給多位收件者

---

使用 VBA 程式碼將行事曆逐一傳送給多位收件者

若要將行事曆分別傳送給多位收件者，以下 VBA 程式碼可協助您達成目的，請依下列步驟操作：

1. 切換至聯絡人窗格，並選取您要傳送行事曆邀請的聯絡人。

2. 接著按下 ALT + F11 鍵，即可開啟 Microsoft Visual Basic for Applications 視窗。

3. 點擊插入＞ 模組，將下方程式碼複製並貼上至開啟的空白模組中，如下圖所示：

VBA 程式碼：將行事曆逐一傳送給多位收件者：

Sub EmailCalendarToMultiplePersonsSeparately()
Dim xSelection As Outlook.Selection
Dim xCalendarFolder As Outlook.Folder
Dim xCalendarExporter As Outlook.CalendarSharing
Dim xStartDate, xEndDate As Date
Dim xCalendarFile As String
Dim xContactItem As Outlook.ContactItem
Dim xDistListItem As Outlook.DistListItem
Dim xItem As Object
Dim xMailItem As Outlook.MailItem
Dim xFilePath, xFileName, xEmailAddress As String
Dim xRecipient As Recipient
On Error Resume Next
xFilePath = CreateObject("WScript.Shell").SpecialFolders(16) & "\MyCalendar"
If Dir(xFilePath, vbDirectory) = "" Then MkDir xFilePath
If Outlook.Application.ActiveExplorer.CurrentFolder.DefaultItemType <> olContactItem Then
    MsgBox "Please Select contacts first!", vbExclamation + vbOKOnly, "Kutools for Outlook"
    Exit Sub
End If
Set xSelection = Outlook.Application.ActiveExplorer.Selection
If xSelection Is Nothing Then Exit Sub
Set xCalendarFolder = Outlook.Application.Session.PickFolder
If xCalendarFolder Is Nothing Then Exit Sub
If xCalendarFolder.DefaultItemType <> olAppointmentItem Then Exit Sub
Set xCalendarExporter = xCalendarFolder.GetCalendarExporter
xStartDate = InputBox("Enter the start date:", "Kutools for Outlook", "")
If Len(Trim(xStartDate)) = 0 Then Exit Sub
xEndDate = InputBox("Enter the end date:", "Kutools for Outlook", "")
If Len(Trim(xEndDate)) = 0 Then Exit Sub
If xStartDate = #1/1/4501# Or xEndDate = #1/1/4501# Then Exit Sub
xFileName = "Calendar (" & Format(xStartDate, "YYYYMMDD") & " - " & Format(xEndDate, "YYYYMMDD") & ").ics"
xCalendarFile = xFilePath & "\" & xFileName
With xCalendarExporter
    .IncludeWholeCalendar = False
    .StartDate = xStartDate
    .EndDate = xEndDate
    .CalendarDetail = olFullDetails
    .IncludeAttachments = True
    .IncludePrivateDetails = False
    .RestrictToWorkingHours = False
    .SaveAsICal xCalendarFile
End With
For Each xItem In xSelection
    If xItem.Class = olContact Then
        Set xContactItem = xItem
        Set xMailItem = Outlook.Application.CreateItem(olMailItem)
        With xMailItem
            .To = xContactItem.Email1Address
            .Recipients.ResolveAll
            .Subject = xFileName
            .Attachments.Add xCalendarFile
            .Body = "Dear " & xContactItem.FullName & "," & vbCrLf & "Type body here..."
            .Display
        End With
    End If
    If xItem.Class = olDistributionList Then
        Set xDistListItem = xItem
        For i = 1 To xDistListItem.MemberCount
            Set xRecipient = xDistListItem.GetMember(i)
            Set xMailItem = Outlook.Application.CreateItem(olMailItem)
            With xMailItem
                .To = xRecipient.AddressEntry.Address
                .Recipients.ResolveAll
                .Subject = xFileName
                .Attachments.Add xCalendarFile
                .Body = "Dear " & xRecipient.Name & "," & vbCrLf & "Type body here..."
                .Display
            End With
        Next i
    End If
Next
End Sub

4. 在插入程式碼後，按下 F5 鍵執行此程式碼，此時會彈出選取資料夾對話方塊，請選擇您要傳送的行事曆，如下圖所示：

5. 點擊確定，然後在隨即出現的提示方塊中指定您要傳送行事曆的日期範圍，如下圖所示：

6. 接著點擊確定，系統將自動建立附帶行事曆的新郵件，如下圖所示，您只需逐一傳送即可！

---

相關文章：

如何在 Outlook 中將電子郵件逐一傳送給多位收件者？

如何透過 Outlook，根據 Excel 名單寄送個人化的大量電子郵件？

如何在 Outlook 中一次傳送多封草稿郵件？

如何在 Outlook 中寄送電子郵件給多位收件者，卻不讓他們彼此看到對方的信箱？