Sends all draft e-mails from a specific Outlook folder

sendAllDrafts.vba

Option Explicit

Private Const VERSION As String = "0.1"
Private Const DIALOG_TITLE As String = "yourModuleName › SendAllDrafts (v" & VERSION & ")"

' Name of the subfolder of the Drafts folder, containing the draft e-mails to be sent
Private Const MAILMERGE_SUBFOLDER_NAME = "MailMerge"

' Send all messages from the MAILMERGE_SUBFOLDER_NAME subfolder
' of the Drafts folder (ignores any subfolder)
Public Sub SendAllDrafts()

    Dim oNamespace As Outlook.NameSpace
    Dim oFolderDrafts As Outlook.Folder, oFolderMailMerge As Outlook.Folder
    Dim oFolderItem As Object, oMessage As Outlook.MailItem
    Dim iCountSent As Integer

On Error GoTo ErrSub

    If MsgBox("Are you sure you want to send ALL the e-mails from the '" _
        & MAILMERGE_SUBFOLDER_NAME & "' subfolder of your Drafts folder?", _
        vbQuestion + vbYesNo, DIALOG_TITLE) <> vbYes Then GoTo ExitSub

    Set oNamespace = Application.GetNamespace("MAPI")

    ' Set oFolderMailMerge = oNamespace.PickFolder
    Set oFolderDrafts = oNamespace.GetDefaultFolder(olFolderDrafts)
    Set oFolderMailMerge = oFolderDrafts.Folders(MAILMERGE_SUBFOLDER_NAME)
    If oFolderMailMerge Is Nothing Then GoTo ErrMissingMailMergeSubfolder

    iCountSent = 0
    Do While oFolderMailMerge.Items.Count > 0
        Set oFolderItem = oFolderMailMerge.Items(1)
        If oFolderItem.Class <> olMail Then GoTo ErrUnsupportedFolderItem
        Set oMessage = oFolderItem
        oMessage.Send
        iCountSent = 1 + iCountSent
    Loop
    MsgBox "Finished sending all draft e-mails from '" & MAILMERGE_SUBFOLDER_NAME & "' subfolder. " _
        & iCountSent & IIf(iCountSent > 1, " messages were", " message was") & " sent.", _
        vbInformation + vbOKOnly, DIALOG_TITLE

ExitSub:
    On Error GoTo 0
    Set oMessage = Nothing
    Set oFolderItem = Nothing
    Set oFolderDrafts = Nothing
    Set oFolderMailMerge = Nothing
    Set oNamespace = Nothing
    Exit Sub

ErrMissingMailMergeSubfolder:
    MsgBox "A subfolder named '" & MAILMERGE_SUBFOLDER_NAME & "' could not be found " _
        & "in the Drafts folder. Create the subfolder, if it does not exist. Otherwise, " _
        & "check the spelling and the case of the folder name, as they are case-sensitive " _
        & "in Outlook. Then start this macro again.", _
        vbOKOnly, DIALOG_TITLE
    GoTo ExitSub

ErrUnsupportedFolderItem:
    MsgBox "Found an unsupported Item type in the '" & MAILMERGE_SUBFOLDER_NAME _
        & "' subfolder of the Drafts folder: " & oFolderItem.Class _
        & "; expected only a MailItem (type " & olMail & "). Try to find " _
        & "and remove the item of offending type and restart the macro.", _
        vbOKOnly, DIALOG_TITLE
    GoTo ExitSub

ErrSub:
    If Err.Number = -2147221233 Then _
        Resume ErrMissingMailMergeSubfolder
    
    ' Regenerate original error.
    ' Dim errNum As Long
    ' errNum = Err.Number
    ' Err.Clear
    ' Err.Raise errNum

    MsgBox Err.Description & vbCrLf & "(" & Err.Number & " - " & Err.Source & ")", vbOKOnly, DIALOG_TITLE
    GoTo ExitSub
End Sub