Outlook で複数の下書きメールを一度に送信するには？

下書きフォルダーに複数の下書きメールがあり、今すぐ1 通ずつ送信せずに一括でまとめて送信したい場合、Outlook でこの作業を素早く簡単に処理するにはどうすればよいでしょうか？

VBA コードを使用してOutlook で一度にすべての下書きメールを送信する

---

VBA コードを使用してOutlook で一度にすべての下書きメールを送信する

以下の VBA コードを使えば、下書きフォルダー内のすべての下書きメール、または選択した下書きメールを一括で送信できます。次の手順に従ってください：

1．ALT + F11キーを押して、Microsoft Visual Basic for Applicationsウィンドウを開きます。

2．次に、挿入＞モジュールをクリックし、開いた空白のモジュールに以下のコードをコピー＆ペーストしてください（スクリーンショットを参照）：

VBA コード：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．コードを保存した後、F5キーを押してコードを実行してください。すべての下書きメールを送信するかどうか確認するプロンプトボックスが表示されるので、はいをクリックしてください（スクリーンショットを参照）：

4．ダイアログボックスが表示され、送信された下書きメールの件数が通知されます（スクリーンショットを参照）：

5．その後、OKボタンをクリックすると、下書きフォルダー内のすべてのメールが一度に送信されます（スクリーンショットを参照）：

注記：

1．上記のコードは、Outlook に設定されているすべてのアカウントの下書きメールを送信します。

2．下書きフォルダーから特定のメールのみを送信したい場合は、以下の VBA コードをご利用ください：

VBA コード：下書きフォルダーから選択したメールを送信する：

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

---

---

関連記事：

Outlook で複数の受信者に個別にメールを送信するには？

Excel のリストを使って、Outlook 経由でパーソナライズされた一斉メールを送信するには？

Outlook で複数の受信者に個別にカレンダーを送信するには？

Outlook で複数の受信者に互いに知られずにメールを送信するには？