Como enviar um calendário individualmente para vários destinatários no Outlook?

Normalmente, pode enviar um calendário a um destinatário de forma rápida e fácil utilizando a funcionalidade Enviar Calendário por E-mail no Outlook. Se pretender enviar um calendário anexado como ficheiro iCalendar a vários contactos individualmente, terá de o fazer um a um. Neste artigo, explico-lhe uma forma simples de enviar um calendário a vários destinatários individualmente no Outlook.

Enviar um calendário a vários destinatários individualmente com código VBA

---

Enviar um calendário a vários destinatários individualmente com código VBA

Para enviar um calendário a vários destinatários individualmente, o código VBA seguinte pode ajudá-lo. Siga estes passos:

1. Aceda ao painel Contactos e selecione os contactos a quem pretende enviar o calendário.

2. Em seguida, prima as teclas ALT + F11 para abrir a janela do Microsoft Visual Basic para Aplicações.

3. Clique em Inserir > Módulo, copie e cole o código seguinte no módulo em branco aberto, conforme mostra a imagem:

Código VBA: Enviar um calendário a vários destinatários individualmente:

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. Após inserir o código, prima a tecla F5 para executar este código. Aparecerá uma caixa de diálogo Selecionar Pasta. Por favor, selecione um calendário que pretende enviar, conforme mostra a imagem:

5.Clique em OKe, em seguida, especifique o Intervalo de Datas a que pretende enviar o calendário nas caixas de diálogo seguintes, conforme mostra a imagem:

6. Depois, clique em OK. Foi criado um novo e-mail com o calendário anexado, conforme mostra a imagem seguinte. Basta agora enviá-lo.

---

Artigos Relacionados:

Como enviar um e-mail a vários destinatários individualmente no Outlook?

Como enviar e-mails personalizados em massa a partir de uma lista do Excel através do Outlook?

Como enviar vários rascunhos em simultâneo no Outlook?

Como enviar um e-mail a vários destinatários sem que eles saibam no Outlook?