How to send multiple drafts at once in Outlook?

If there are multiple draft messages in your Drafts folder, and now, you want to send them at once without sending one by one. How could you deal with this job quickly and easily in Outlook?

Send all draft messages at once in Outlook with VBA code

Send all draft messages at once in Outlook with VBA code

The following VBA codes can help you to send all or selected draft emails from the Drafts folder at once, please do as this:

1. Hold down the ALT + F11 keys to open the Microsoft Visual Basic for Applications window.

2. Then click Insert > Module, copy and paste below code into the opened blank module, see screenshot:

VBA code: Send all draft emails at once in Outlook:

Sub SendAllDraftEmails()
Dim xAccount As Account
Dim xDraftFld As Folder
Dim xItemCount As Integer
Dim xDraftsItems As Outlook.Items
Dim xPromptStr As String
Dim xYesOrNo As Integer
Dim i, k As Long
Dim xNewMail As MailItem
Dim xTmpPath, xFilePath As String
On Error Resume Next
xItemCount = 0
For Each xAccount In Outlook.Application.Session.Accounts
    Set xDraftFld = xAccount.DeliveryStore.GetDefaultFolder(olFolderDrafts)
    xItemCount = xItemCount + xDraftFld.Items.Count
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
        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 i = 1 Then
                    Set xNewMail = Outlook.Application.CreateItem(olMailItem)
                    With xNewMail
                        .SendUsingAccount = xDraftsItems.Item(i).SendUsingAccount
                        .To = xDraftsItems.Item(i).To
                        .CC = xDraftsItems.Item(i).CC
                        .BCC = xDraftsItems.Item(i).BCC
                        .Subject = xDraftsItems.Item(i).Subject
                        If xDraftsItems.Item(i).Attachments.Count > 0 Then
                            xTmpPath = "C:\MyTempAttachments"
                            If Dir(xTmpPath, vbDirectory) = "" Then
                                MkDir xTmpPath
                            End If
                            For k = xDraftsItems.Item(i).Attachments.Count To 1 Step -1
                                xFilePath = xTmpPath & "\" & xDraftsItems.Item(i).Attachments.Item(k).FileName
                                xDraftsItems.Item(i).Attachments.Item(k).SaveAsFile xFilePath
                                xNewMail.Attachments.Add (xFilePath)
                                Kill xFilePath
                            Next k
                            RmDir xTmpPath
                        End If
                        .HTMLBody = xDraftsItems.Item(i).HTMLBody
                        .Send
                    End With
                    xDraftsItems.Item(i).Delete
                Else
                    xDraftsItems.Item(i).Send
                End If
            Next
        Next xAccount
        MsgBox "Successfully sent " & xItemCount & " messages", vbInformation, "Kutools for Outlook"
    End If
Else
    MsgBox "No Drafts!", vbInformation + vbOKOnly, "Kutools for Outlook"
End If
End Sub

3. Then save the code, and press F5 key to run this code, a prompt box will pop up to remind you if send all the drafts, click Yes, see screenshot:

4. And a dialog box will pop out to remind you how many draft emails have been sent out, see screenshot:

5. And then click OK button, all the emails in the Drafts folder will be sent at once, see screenshot:

Notes:

1. The above code will send all draft emails from all accounts in your Outlook.

2. If you just want to send some specific emails from the Drafts folder, please apply the following VBA code:

VBA code: Send selected emails from the Drafts folder:

Sub SendSelectedDraftEmails()
Dim xSelection As Selection
Dim xPromptStr As String
Dim xYesOrNo As Integer
Dim i As Long
Dim xNewMail As MailItem
Dim xTmpPath, xFilePath As String
On Error Resume Next
If Outlook.Application.Session.GetDefaultFolder(olFolderDrafts).Name <> _
   Outlook.Application.ActiveExplorer.CurrentFolder.Name 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
      For i = xSelection.Count To 1 Step -1
          If i = 1 Then
              Set xNewMail = Outlook.Application.CreateItem(olMailItem)
              With xNewMail
                  .SendUsingAccount = xSelection.Item(i).SendUsingAccount
                  .To = xSelection.Item(i).To
                  .CC = xSelection.Item(i).CC
                  .BCC = xSelection.Item(i).BCC
                  .Subject = xSelection.Item(i).Subject
                   If xSelection.Item(i).Attachments.Count > 0 Then
                      xTmpPath = "C:\MyTempAttachments"
                      If Dir(xTmpPath, vbDirectory) = "" Then
                          MkDir xTmpPath
                      End If
                      For k = xSelection.Item(i).Attachments.Count To 1 Step -1
                          xFilePath = xTmpPath & "\" & xSelection.Item(i).Attachments.Item(k).FileName
                          xSelection.Item(i).Attachments.Item(k).SaveAsFile xFilePath
                          xNewMail.Attachments.Add (xFilePath)
                          Kill xFilePath
                      Next k
                      RmDir xTmpPath
                  End If
                  .HTMLBody = xSelection.Item(i).HTMLBody
                  .Send
              End With
              xSelection.Item(i).Delete
          Else
              xSelection.Item(i).Send
          End If
      Next
      MsgBox "Successfully sent " & xSelection.Count & " messages", vbInformation, "Kutools for Outlook"
   End If
Else
   MsgBox "No items selected!", vbInformation, "Kutools for Outlook"
End If
End Sub

Related Articles:

How To Send An Email To Multiple Recipients Individually In Outlook?

How To Send Personalized Mass Emails To A List From Excel Via Outlook?

How To Send A Calendar To Multiple Recipients Individually In Outlook?

How To Send Email To Multiple Recipients Without Them Knowing In Outlook?

Kutools for Outlook - Brings 100 Advanced Features to Outlook, and Make Work Much Easier!

• Auto CC/BCC by rules when sending email; Auto Forward Multiple Emails by custom; Auto Reply without exchange server, and more automatic features...
• BCC Warning - show message when you try to reply all if your mail address is in the BCC list; Remind When Missing Attachments, and more remind features...
• Reply (All) With All Attachments in the mail conversation; Reply Many Emails in seconds; Auto Add Greeting when reply; Add Date into subject...
• Attachment Tools: Manage All Attachments in All Mails, Auto Detach, Compress All, Rename All, Save All... Quick Report, Count Selected Mails...
• Powerful Junk Emails by custom; Remove Duplicate Mails and Contacts... Enable you to do smarter, faster and better in Outlook.

Read More... Download Now...