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
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
Reply all selected emails at once in Outlook: If you have multiple emails needed to be replied, rely them one by one will waste much time, but, with Kutools for Outlook's Bulk Reply feature, you can solve this job as quickly as you could. Kutools for Outlook: with more than 100+ handy Excel add-ins, free to try with no limitation in 60 days. Download and try the free trial now! |
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?
