Wie können Sie mehrere Entwürfe in Outlook gleichzeitig versenden?

Wenn sich mehrere Nachrichtenentwürfe in Ihrem „Entwürfe“-Ordner befinden und Sie diese alle auf einmal versenden möchten, ohne sie einzeln öffnen und senden zu müssen – wie erledigen Sie diese Aufgabe schnell und einfach in Outlook?

Senden Sie alle Entwurfsnachrichten gleichzeitig in Outlook mithilfe eines VBA-Codes

---

Senden Sie alle Entwurfsnachrichten gleichzeitig in Outlook mithilfe eines VBA-Codes

Die folgenden VBA-Codes ermöglichen es Ihnen, alle oder ausgewählte Entwurfs-E-Mails aus dem Ordner „Entwürfe“ mit einem Klick zu versenden. Gehen Sie dazu wie folgt vor:

1. Halten Sie die Tasten ALT + F11 gedrückt, um das Fenster Microsoft Visual Basic for Applications zu öffnen.

2. Klicken Sie anschließend auf Einfügen > Modul, und fügen Sie den unten stehenden Code in das geöffnete leere Modul ein (siehe Screenshot):

VBA-Code: Alle Entwurfs-E-Mails gleichzeitig in Outlook versenden:

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. Speichern Sie den Code und drücken Sie anschließend die Taste F5, um ihn auszuführen. Es erscheint ein Eingabefeld, das Sie fragt, ob alle Entwürfe gesendet werden sollen. Klicken Sie auf Ja (siehe Screenshot):

4. Anschließend erscheint ein Dialogfeld, das Ihnen anzeigt, wie viele Entwurfs-E-Mails versendet wurden (siehe Screenshot):

5. Klicken Sie dann auf die Schaltfläche OK, und alle E-Mails im Ordner Entwürfe werden auf einmal versendet (siehe Screenshot):

Hinweise:

1. Der obige Code versendet alle Entwurfs-E-Mails aus sämtlichen Konten in Ihrem Outlook.

2. Wenn Sie nur bestimmte E-Mails aus dem Ordner „Entwürfe“ versenden möchten, nutzen Sie bitte den folgenden VBA-Code:

VBA-Code: Ausgewählte E-Mails aus dem Ordner „Entwürfe“ versenden:

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

---

---

Verwandte Artikel:

Wie sendet man in Outlook eine E-Mail einzeln an mehrere Empfänger?

Wie sendet man personalisierte Massen-E-Mails an eine Empfängerliste aus Excel über Outlook?

Wie sendet man einen Kalender in Outlook einzeln an mehrere Empfänger?

Wie sendet man in Outlook eine E-Mail an mehrere Empfänger, ohne dass diese voneinander wissen?