How to send a calendar to multiple recipients individually in Outlook?
Normally, you can send a calendar to a recipient quickly and easily by using the E-mail Calendar feature in Outlook. If you want to send a calendar attached as iCalendar file to multiple contacts individually, you need to send it one by one. In this article, I will talk about an easy way to send a calendar to multiple recipients individually in Outlook.
To send a calendar to multiple recipients separately, the following VBA code can help you, please do as this:
1. Navigate to the Contacts pane, and select the contacts that you want to send calendar to.
2. Then hold down the ALT + F11 keys to open the Microsoft Visual Basic for Applications window.
3. Click Insert > Module, copy and paste below code into the opened blank module, see screenshot:
VBA code: Send a calendar to multiple recipients individually：
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. After inserting the code, then press F5 key to run this code, and a Select Folder dialog box is popped out, please select a calendar which you want to send, see screenshot:
5. Click OK, and then specify the date range that you want to send the calendar in the following prompt boxes, see screenshot:
6. And then, click OK, new emails with calendar attached have been created as following screenshot shown, then you just need to send them one by one.
Kutools for Outlook
More than 100 Advanced Functions for Outlook 2010, 2013, 2016, 2019 and 365