¿Cómo enviar varios borradores a la vez en Outlook?

Si tiene varios mensajes en borrador en la carpeta Borradores y desea enviarlos todos a la vez sin tener que hacerlo uno por uno, ¿cómo puede realizar esta tarea de forma rápida y sencilla en Outlook?

Enviar todos los mensajes en borrador a la vez en Outlook con código VBA

---

Enviar todos los mensajes en borrador a la vez en Outlook con código VBA

Los siguientes códigos VBA le permiten enviar todos o solo algunos de los correos electrónicos seleccionados en la carpeta Borradores, ¡todo de una sola vez! Siga estos sencillos pasos:

1. Mantenga pulsadas las teclas ALT + F11 para abrir la ventana de Microsoft Visual Basic para Aplicaciones.

2. A continuación, haga clic en Insertar > Módulo, copie y pegue el siguiente código en el módulo en blanco que se abre. Consulte la captura de pantalla:

Código VBA: Enviar todos los correos electrónicos en borrador a la vez en 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. A continuación, guarde el código y pulse la tecla F5 para ejecutarlo. Aparecerá un cuadro de diálogo preguntándole si desea enviar todos los borradores. Haga clic en Sí. Consulte la captura de pantalla:

4. A continuación aparecerá un cuadro de diálogo que le indicará cuántos correos electrónicos en borrador se han enviado. Consulte la captura de pantalla:

5. A continuación, haga clic en el botón Aceptar y todos los correos electrónicos de la carpeta Borradores se enviarán a la vez. Consulte la captura de pantalla:

Notas:

1. El código anterior enviará todos los correos electrónicos en borrador de todas sus cuentas de Outlook.

2. Si solo desea enviar algunos correos electrónicos específicos de la carpeta Borradores, utilice el siguiente código VBA:

Código VBA: Enviar correos electrónicos seleccionados desde la carpeta Borradores:

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

---

---

Artículos relacionados:

¿Cómo enviar un correo electrónico a varios destinatarios de forma individual en Outlook?

¿Cómo enviar correos electrónicos masivos personalizados a una lista desde Excel mediante Outlook?

¿Cómo enviar un calendario a varios destinatarios de forma individual en Outlook?

¿Cómo enviar un correo electrónico a varios destinatarios en Outlook sin que ellos lo sepan?