Note: The other languages of the website are Google-translated. Back to English
English English

Como enviar vários rascunhos de uma vez no Outlook?

Se houver vários rascunhos de mensagens em sua pasta Rascunhos, e agora você deseja enviá-los de uma vez, sem enviar um por um. Como você poderia lidar com esse trabalho de forma rápida e fácil no Outlook?

Envie todas as mensagens de rascunho de uma vez no Outlook com código VBA


Envie todas as mensagens de rascunho de uma vez no Outlook com código VBA

Os seguintes códigos VBA podem ajudá-lo a enviar todos os e-mails de rascunho ou alguns selecionados da pasta Rascunhos de uma só vez, faça o seguinte:

1. Segure o ALT + F11 chaves para abrir o Microsoft Visual Basic para Aplicações janela.

2. Então clique inserção > Módulo, copie e cole o código abaixo no módulo em branco aberto, veja a captura de tela:

Código VBA: envie todos os rascunhos de e-mails de uma vez no 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. Em seguida, salve o código e pressione F5 para executar este código, uma caixa de prompt aparecerá para lembrá-lo se enviar todos os rascunhos, clique Sim, veja a captura de tela:

4. E uma caixa de diálogo aparecerá para lembrá-lo de quantos rascunhos de e-mails foram enviados, veja a captura de tela:

5. E, em seguida, clique em OK botão, todos os e-mails no Esboços pasta será enviada de uma vez, veja a imagem:

notas:

1. O código acima enviará todos os rascunhos de e-mails de todas as contas em seu Outlook.

2. Se você deseja apenas enviar alguns e-mails específicos da pasta Rascunhos, aplique o seguinte código VBA:

Código VBA: Envie e-mails selecionados da pasta Rascunhos:

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

Artigos relacionados:

Como enviar um e-mail para vários destinatários individualmente no Outlook?

Como enviar emails em massa personalizados para uma lista do Excel via Outlook?

Como enviar um calendário para vários destinatários individualmente no Outlook?

Como enviar e-mail para vários destinatários sem que eles saibam no Outlook?


Kutools for Outlook - traz 100 recursos avançados para o Outlook e torna o trabalho muito mais fácil!

  • Auto CC / BCC por regras ao enviar e-mail; Avanço automático Vários emails por encomenda; Resposta automatica sem servidor Exchange e mais recursos automáticos ...
  • Aviso BCC - mostrar mensagem quando você tentar responder a todos se o seu endereço de e-mail estiver na lista BCC; Lembrar quando houver anexos ausentes, e mais recursos de lembrete ...
  • Responder (todos) com todos os anexos na conversa de correio; Responder muitos e-mails em segundos; Adicionar saudação automaticamente quando responder; Adicionar data ao assunto ...
  • Ferramentas de anexo: gerenciar todos os anexos em todos os e-mails, Desanexação Automática, Comprimir tudo, Renomear tudo, Salvar tudo ... Relatório rápido, Contar e-mails selecionados...
  • Lixo eletrônico poderoso por costume; Remover e-mails e contatos duplicados... Permite que você faça de maneira mais inteligente, rápida e melhor no Outlook.
tiro kutools aba kutools do outlook 1180x121
tiro kutools outlook kutools mais guia 1180x121
 
Comentários (15)
Ainda não há classificações. Seja o primeiro a avaliar!
Este comentário foi feito pelo moderador no site
Brilhante, funcionou um charme, obrigado :)
Este comentário foi feito pelo moderador no site
einfach nur perfeito. Herzlichen Dank
Este comentário foi feito pelo moderador no site
Copiado conforme acima, mas quando pressiono F5 nada acontece
Este comentário foi feito pelo moderador no site
Olá, Catleen,
O código acima funciona bem no meu Outlook, qual versão do Outlook você usa?
Este comentário foi feito pelo moderador no site
Tenho várias contas de câmbio. Eu quero ter uma das contas que não é meu padrão para ser o remetente. Onde eu inseriria isso no código? Obrigado!
Este comentário foi feito pelo moderador no site
Alguém recebe alguns e-mails enviados para a pasta excluída fazendo isso?
Este comentário foi feito pelo moderador no site
Olá, Bill,
Deseja enviar vários e-mails selecionados do foder excluído?
Por favor, descreva seu problema com mais detalhes, obrigado!
Este comentário foi feito pelo moderador no site
Oi skyyang, estou enfrentando o mesmo problema. Eu geralmente rascunho de 15 a 20 e-mails e, em seguida, uso esse código para enviá-los todos de uma vez, mas depois percebo que um desses e-mails não é enviado, mas é enviado para minha pasta 'Excluído'. Mesmo o prompt diz o número correto de e-mails, por exemplo: '20 e-mails enviados', mas quando eu verifico, apenas 19 teriam sido enviados, um que eu encontrarei na minha pasta de itens excluídos. Quero que todos os e-mails sejam enviados para seus destinatários sem erros. Você pode por favor me dizer por que isso acontece. Por favor ajude.
Este comentário foi feito pelo moderador no site
Oi, Darewin, Atualizamos os códigos acima, por favor tente novamente, obrigado!
Este comentário foi feito pelo moderador no site
Mesmo problema: se você selecionar 4 mensagens, depois de enviar três delas vão para a lixeira (por causa da declaração "xDraftsItems.Item(i).Delete")
Este comentário foi feito pelo moderador no site
Usamos o script para enviar todos os rascunhos de e-mails de uma só vez para um lote de e-mails de declaração gerados a partir do sage 200. Os e-mails nos itens enviados parecem bons, mas os clientes os estão recebendo com o corpo do texto em chinês! Alguma ideia do que pode estar acontecendo aqui?
Este comentário foi feito pelo moderador no site
Você pode explicar por que o último email (i = 1) é recriado em um novo MailItem em vez de apenas .Send?

Obrigado.
Este comentário foi feito pelo moderador no site
Oi, pergunta rápida talvez você tenha uma idéia. Temos um aplicativo externo que salva todos os e-mails na pasta de rascunhos. se eu executar a macro temos o problema, que apenas o primeiro email da lista está sendo enviado corretamente, todos os outros emails são adiados porque adiciona aspas ' ' ao endereço de email. Existe uma maneira de evitar isso?
Este comentário foi feito pelo moderador no site
Este código envia todos os rascunhos em uma subpasta chamada Merge Tools (ele pergunta antes de enviar). Tenho certeza que vocês podem editá-lo para atender às suas necessidades. É muito mais simples. Apreciar :)
Sub SendAllMergeToolsRascunhos()

If MsgBox("Tem certeza de que deseja enviar TODOS os itens em sua pasta de rascunhos Merge Tools?", _
vbQuestion + vbYesNo) <> vbYes Then Exit Sub

Dim myNamespace As Outlook.NameSpace 'Altere a exibição para Caixa de entrada para evitar erros embutidos
Set myNamespace = Application.GetNamespace("MAPI") 'Mude a visualização para a caixa de entrada para evitar erros inline
Definir Application.ActiveExplorer.CurrentFolder = _
myNamespace.GetDefaultFolder(olFolderInbox) 'Alterar a visualização para Caixa de entrada para evitar erro inline

Dim fldDraft As MAPIFolder, msg As Outlook.MailItem, intCount As Integer
Set fldDraft = Outlook.GetNamespace("MAPI").GetDefaultFolder(olFolderDrafts).Folders("Merge Tools") 'Envia todos os rascunhos apenas na pasta Merge Tools
intCont = 0
Faça Enquanto fldDraft.Items.count > 0
Definir msg = fldDraft.Items(1)
msg.Enviar
intCont = intCont + 1
laço
Se não (msg é nada) então defina msg = Nothing
Definir fldDraft = Nada
MsgBox intCount & "mensagens enviadas", vbInformation + vbOKOnly

End Sub
Este comentário foi feito pelo moderador no site
Oi, pessoal. Pensei em compartilhar. Aqui está meu código para enviar todos os rascunhos:
Sub SendAllDrafts() 'Por jamesmalcolmwood@gmail.com

If MsgBox("Tem certeza de que deseja enviar TODOS os itens em sua pasta de rascunhos?", _
vbQuestion + vbYesNo) <> vbYes Then Exit Sub

Dim myNamespace As Outlook.NameSpace 'Altere a exibição para Caixa de entrada para evitar erros embutidos
Set myNamespace = Application.GetNamespace("MAPI") 'Mude a visualização para a caixa de entrada para evitar erros inline
Definir Application.ActiveExplorer.CurrentFolder = _
myNamespace.GetDefaultFolder(olFolderInbox) 'Alterar a visualização para Caixa de entrada para evitar erro inline

Dim fldDraft As MAPIFolder, msg As Outlook.MailItem, intCount As Integer
Set fldDraft = Outlook.GetNamespace("MAPI").GetDefaultFolder(olFolderDrafts) 'Envia todos os rascunhos em sua pasta principal de rascunhos. Para uma subpasta, adicione .Folders("nome da pasta")
intCont = 0
Faça Enquanto fldDraft.Items.count > 0
Definir msg = fldDraft.Items(1)
msg.Enviar
intCont = intCont + 1
laço
Se não (msg é nada) então defina msg = Nothing
Definir fldDraft = Nada
MsgBox intCount & "mensagens enviadas", vbInformation + vbOKOnly

End Sub
Não há comentários postados aqui ainda
Deixe o seu comentário
Postando como convidado
×
Avalie esta postagem:
0   Personagens
Locais sugeridos