如何在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 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。 然後保存代碼，然後按 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 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

相關文章：

如何在Outlook中單獨向多個收件人發送電子郵件？

如何通過Outlook從Excel發送個性化群發電子郵件到列表？

如何在Outlook中單獨向多個收件人發送日曆？

如何在不知道Outlook的情況下向多個收件人發送電子郵件？

Kutools for Outlook - 為Outlook帶來100高級功能，讓工作更輕鬆！

• 自動CC / BCC 發送電子郵件時的規則; 自動轉發 多個電子郵件按自定義; 自動回复 沒有交換服務器，以及更多自動功能......
• BCC警告 - 當您嘗試回复所有內容時顯示消息 如果您的郵件地址在BCC列表中; 缺少附件時提醒，以及更多提醒功能......
• 回复（全部）使用郵件會話中的所有附件; 回复很多電子郵件 很快; 自動添加問候語 回复時; 將日期添加到主題...
• 附件工具：管理所有郵件中的所有附件， 自動分離, 全部壓縮，重命名全部，全部保存...快速報告， 計算選定的郵件...
• 強大的垃圾郵件 按慣例; 刪除重複郵件和聯繫人... 使您能夠在Outlook中更智能，更快速，更好地完成工作。

閱讀更多... 現在下載...