如何在 Outlook 中一次發送多封草稿郵件？

如果您的「草稿」資料夾中有許多草稿郵件，想一次全部發送，而不必逐一傳送，該如何在 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. 點擊確定按鈕後，「草稿」資料夾中的所有郵件將一次發送完畢，如下圖所示：

注意事項：

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 中逐一寄送電子郵件給多位收件者？

如何透過 Outlook，根據 Excel 名單寄送個人化的大量電子郵件？

如何在 Outlook 中將行事曆個別寄送給多位收件者？

如何在 Outlook 中寄送電子郵件給多位收件者，同時隱藏彼此的聯絡資訊？