Hoe verzendt u meerdere concepten tegelijkertijd in Outlook?

Als er meerdere conceptberichten in uw map Concepten staan en u wilt ze allemaal tegelijk verzenden zonder ze één voor één te hoeven versturen, hoe kunt u deze taak dan snel en eenvoudig uitvoeren in Outlook?

Verzend alle conceptberichten tegelijk in Outlook met VBA-code

---

Verzend alle conceptberichten tegelijk in Outlook met VBA-code

De volgende VBA-codes helpen u om alle of geselecteerde concept-e-mails uit de map Concepten tegelijkertijd te verzenden. Volg deze stappen:

1. Houd de toetsen ALT + F11 ingedrukt om het venster Microsoft Visual Basic for Applications te openen.

2. Klik vervolgens op Invoegen > Module, kopieer de onderstaande code en plak deze in de geopende lege module; zie schermafbeelding:

VBA-code: Verzend alle concept-e-mails tegelijk 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. Sla de code op en druk op F5 om deze uit te voeren. Er verschijnt een meldingsvenster waarin u wordt gevraagd of u alle concepten wilt verzenden; klik op Ja. Zie schermafbeelding:

4. Vervolgens verschijnt een dialoogvenster met de melding hoeveel concept-e-mails zijn verzonden. Zie de schermafbeelding:

5. Klik daarna op de knop OK, waarna alle e-mails in de map Concepten tegelijk worden verzonden; zie schermafbeelding:

Opmerkingen:

1. De bovenstaande code verzendt automatisch alle concept-e-mails van al uw Outlook-accounts.

2. Als u alleen bepaalde e-mails uit de map Concepten wilt verzenden, gebruikt u de volgende VBA-code:

VBA-code: Verzend geselecteerde e-mails uit de map Concepten:

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

---

---

Gerelateerde artikelen:

Hoe stuurt u een e-mail individueel naar meerdere ontvangers in Outlook?

Hoe verzendt u gepersonaliseerde bulkmails vanuit Excel naar een lijst via Outlook?

Hoe stuurt u een agenda-indeling individueel naar meerdere ontvangers in Outlook?

Hoe stuurt u in Outlook een e-mail naar meerdere ontvangers zonder dat zij van elkaars ontvangst weten?