Come inviare più bozze contemporaneamente in Outlook?

Se nella cartella Bozze sono presenti più messaggi in bozza e si desidera inviarli tutti insieme, senza doverli spedire uno per volta, come si può eseguire questa operazione in modo rapido e semplice in Outlook?

Inviare tutti i messaggi in bozza contemporaneamente in Outlook con codice VBA

---

Inviare tutti i messaggi in bozza contemporaneamente in Outlook con codice VBA

I seguenti codici VBA consentono di inviare contemporaneamente tutte le email presenti nella cartella Bozze oppure solo quelle selezionate. Procedere come segue:

1. Tenere premuti i tasti ALT + F11 per aprire la finestra di Microsoft Visual Basic for Applications.

2. Fare quindi clic su Inserisci > Modulo, quindi copiare e incollare il codice seguente nel modulo vuoto appena aperto (vedere screenshot):

Codice VBA: inviare contemporaneamente tutte le email in bozza in Outlook:

Sub SendAllDraftEmails()
Dim xAccount As Account
Dim xDraftFld As Folder
Dim xItemCount As Integer
Dim xCount As Integer
Dim xDraftsItems As Outlook.Items
Dim xPromptStr As String
Dim xYesOrNo As Integer
Dim i As Long
Dim xCurFld As Folder
Dim xTmpFld As Folder
On Error Resume Next
xItemCount = 0
xCount = 0
Set xTmpFld = Nothing
Set xCurFld = Application.ActiveExplorer.CurrentFolder
For Each xAccount In Outlook.Application.Session.Accounts
    Set xDraftFld = xAccount.DeliveryStore.GetDefaultFolder(olFolderDrafts)
    xItemCount = xItemCount + xDraftFld.Items.Count
    If xDraftFld.EntryID = xCurFld.EntryID Then
        Set xTmpFld = xCurFld.Parent
    End If
Next xAccount
Set xDraftFld = Nothing
If xItemCount > 0 Then
   xPromptStr = "Are you sure to send out all the drafts?"
    xYesOrNo = MsgBox(xPromptStr, vbQuestion + vbYesNo, "Kutools for Outlook")
    If xYesOrNo = vbYes Then
        If Not xTmpFld Is Nothing Then
            Set Application.ActiveExplorer.CurrentFolder = xTmpFld
        End If
        VBA.DoEvents
        For Each xAccount In Outlook.Application.Session.Accounts
            Set xDraftFld = xAccount.DeliveryStore.GetDefaultFolder(olFolderDrafts)
            Set xDraftsItems = xDraftFld.Items
            For i = xDraftsItems.Count To 1 Step -1
                If xDraftsItems.Item(i).Recipients.Count <> 0 Then
                    xDraftsItems.Item(i).sEnd
                    xCount = xCount + 1
                End If
            Next
        Next xAccount
        VBA.DoEvents
        Set Application.ActiveExplorer.CurrentFolder = xCurFld
        MsgBox "Successfully sent " & xCount & " messages", vbInformation, "Kutools for Outlook"
    End If
Else
    MsgBox "No Drafts!", vbInformation + vbOKOnly, "Kutools for Outlook"
End If
End Sub

3. Salvare quindi il codice e premere il tasto F5 per eseguirlo. Comparirà una finestra di conferma che chiederà se inviare tutte le bozze; fare clic su Sì (vedere screenshot):

4. Verrà visualizzata una finestra di dialogo con l’indicazione del numero di email in bozza inviate (vedere screenshot):

5. Fare quindi clic sul pulsante OK; tutte le email presenti nella cartella Bozze verranno inviate contemporaneamente (vedere screenshot):

Note:

1. Il codice sopra riportato invierà automaticamente tutte le email in bozza presenti in tutti gli account configurati in Outlook.

2. Se invece si desidera inviare solo alcuni messaggi specifici dalla cartella Bozze, utilizzare il seguente codice VBA:

Codice VBA: inviare le email selezionate dalla cartella Bozze:

Sub SendSelectedDraftEmails()
Dim xSelection As Selection
Dim xPromptStr As String
Dim xYesOrNo As Integer
Dim i As Long
Dim xAccount As Account
Dim xCurFld As Folder
Dim xDraftsFld As Folder
Dim xTmpFld As Folder
Dim xArr() As String
Dim xCount As Integer
Dim xMail As MailItem
On Error Resume Next
xCount = 0
Set xTmpFld = Nothing
Set xCurFld = Application.ActiveExplorer.CurrentFolder
For Each xAccount In Outlook.Application.Session.Accounts
    Set xDraftsFld = xAccount.DeliveryStore.GetDefaultFolder(olFolderDrafts)
    If xDraftsFld.EntryID = xCurFld.EntryID Then
        Set xTmpFld = xCurFld.Parent
    End If
Next xAccount
If xTmpFld Is Nothing Then
    MsgBox "The current folder is not a draft folder", vbInformation, "Kutools for Outlook"
    Exit Sub
End If
Set xSelection = Outlook.Application.ActiveExplorer.Selection
If xSelection.Count > 0 Then
    xPromptStr = "Are you sure to send out the selected " & xSelection.Count & " draft item(s)?"
    xYesOrNo = MsgBox(xPromptStr, vbQuestion + vbYesNo, "Kutools for Outlook")
    If xYesOrNo = vbYes Then
        ReDim xArr(xSelection.Count - 1)
        For i = 1 To xSelection.Count
            xArr(i - 1) = xSelection.Item(i).EntryID
        Next
        Set Application.ActiveExplorer.CurrentFolder = xTmpFld
        VBA.DoEvents
        For i = 0 To UBound(xArr)
            Set xMail = Application.Session.GetItemFromID(xArr(i))
            If xMail.Recipients.Count <> 0 Then
                xMail.sEnd
                xCount = xCount + 1
            End If
        Next
        VBA.DoEvents
        Set Application.ActiveExplorer.CurrentFolder = xCurFld
        MsgBox "Successfully sent " & xCount & " messages", vbInformation, "Kutools for Outlook"
    End If
Else
    MsgBox "No items selected!", vbInformation, "Kutools for Outlook"
End If
End Sub

---

---

Articoli correlati:

Come inviare un'email a più destinatari in modo individuale in Outlook?

Come inviare email personalizzate in massa a una lista di destinatari da un file Excel tramite Outlook?

Come inviare un calendario a più destinatari singolarmente in Outlook?

Come inviare un'email a più destinatari in Outlook senza che questi vedano gli altri indirizzi?