Skip to main content

Kutools para Office — Uma Suíte. Cinco Ferramentas. Aumente sua Produtividade.

Como converter ou salvar e-mail e anexos em um único arquivo PDF no Outlook?

Author Siluvia Last modified

Este artigo trata de salvar uma mensagem de e-mail e todos os anexos dentro dela em um único arquivo PDF no Outlook.

Converter ou salvar e-mail e anexos em um único arquivo PDF com código VBA

Converter ou salvar e-mail e anexos em um único arquivo PDF com código VBA

Por favor, siga as instruções abaixo para salvar o e-mail com todos os seus anexos em um único arquivo PDF no Outlook.

1. Selecione um e-mail com anexos que você deseja salvar em um único arquivo PDF e pressione as teclas Alt + F11 para abrir a janela Microsoft Visual Basic for Applications.

2. Na janela Microsoft Visual Basic for Applications, clique em Inserir > Módulo. Em seguida, copie o seguinte código VBA na janela Módulo.

Código VBA: Salvar e-mail e anexo em um único arquivo PDF

Public Sub MergeMailAndAttachsToPDF()
'Update by Extendoffice 2018/3/5
Dim xSelMails As MailItem
Dim xFSysObj As FileSystemObject
Dim xOverwriteBln As Boolean
Dim xLooper As Integer
Dim xEntryID As String
Dim xNameSpace As Outlook.NameSpace
Dim xMail As Outlook.MailItem
Dim xExt As String
Dim xSendEmailAddr, xCompanyDomain As String
Dim xWdApp As Word.Application
Dim xDoc, xNewDoc As Word.Document
Dim I As Integer
Dim xPDFSavePath As String
Dim xPath As String
Dim xFileArr() As String
Dim xExcel As Excel.Application
Dim xWb As Workbook
Dim xWs As Worksheet
Dim xTempDoc As Word.Document

On Error Resume Next
If (Outlook.ActiveExplorer.Selection.Count > 1) Or (Outlook.ActiveExplorer.Selection.Count = 0) Then
    MsgBox "Please Select a email.", vbInformation + vbOKOnly
    Exit Sub
End If
Set xSelMails = Outlook.ActiveExplorer.Selection.Item(1)
xEntryID = xSelMails.EntryID
Set xNameSpace = Application.GetNamespace("MAPI")
Set xMail = xNameSpace.GetItemFromID(xEntryID)

xSendEmailAddr = xMail.SenderEmailAddress
xCompanyDomain = Right(xSendEmailAddr, Len(xSendEmailAddr) - InStr(xSendEmailAddr, "@"))
xOverwriteBln = False
Set xExcel = New Excel.Application
xExcel.Visible = False
Set xWdApp = New Word.Application
xExcel.DisplayAlerts = False
xPDFSavePath = xExcel.Application.GetSaveAsFilename(InitialFileName:="", FileFilter:="PDF Files(*.pdf),*.pdf")
If xPDFSavePath = "False" Then
    xExcel.DisplayAlerts = True
    xExcel.Quit
    xWdApp.Quit
    Exit Sub
End If
xPath = Left(xPDFSavePath, InStrRev(xPDFSavePath, "\"))
cPath = xPath & xCompanyDomain & "\"
yPath = cPath & Format(Now(), "yyyy") & "\"
mPath = yPath & Format(Now(), "MMMM") & "\"
If Dir(xPath, vbDirectory) = vbNullString Then
   MkDir xPath
End If
EmailSubject = CleanFileName(xMail.Subject)
xSaveName = Format(xMail.ReceivedTime, "yyyymmdd") & "_" & EmailSubject & ".doc"
Set xFSysObj = CreateObject("Scripting.FileSystemObject")
If xOverwriteBln = False Then
   xLooper = 0
  Do While xFSysObj.FileExists(yPath & xSaveName)
      xLooper = xLooper + 1
      xSaveName = Format(xMail.ReceivedTime, "yyyymmdd") & "_" & EmailSubject & "_" & xLooper & ".doc"
   Loop
Else
   If xFSysObj.FileExists(yPath & xSaveName) Then
      xFSysObj.DeleteFile yPath & xSaveName
   End If
End If
xMail.SaveAs xPath & xSaveName, olDoc
If xMail.Attachments.Count > 0 Then
   For Each atmt In xMail.Attachments
      xExt = SplitPath(atmt.filename, 2)
      If (xExt = ".docx") Or (xExt = ".doc") Or (xExt = ".docm") Or (xExt = ".dot") Or (xExt = ".dotm") Or (xExt = ".dotx") _
      Or (xExt = ".xlsx") Or (xExt = ".xls") Or (xExt = ".xlsm") Or (xExt = ".xlt") Or (xExt = ".xltm") Or (xExt = ".xltx") Then
        atmtName = CleanFileName(atmt.filename)
        atmtSave = xPath & Format(xMail.ReceivedTime, "yyyymmdd") & "_" & atmtName
        atmt.SaveAsFile atmtSave
      End If
   Next
End If
Set xNewDoc = xWdApp.Documents.Add("Normal", False, wdNewBlankDocument, False)
Set xFilesFld = xFSysObj.GetFolder(xPath)
xFileArr() = GetFiles(xPath)
For I = 0 To UBound(xFileArr()) - 1
    xExt = SplitPath(xFileArr(I), 2)
    If (xExt = ".xlsx") Or (xExt = ".xls") Or (xExt = ".xlsm") Or (xExt = ".xlt") Or _
       (xExt = ".xltm") Or (xExt = ".xltx") Then  'conver excel to word
        Set xWb = xExcel.Workbooks.Open(xPath & xFileArr(I))
        Set xTempDoc = xWdApp.Documents.Add("Normal", False, wdNewBlankDocument, False)
        Set xWs = xWb.ActiveSheet
        xWs.UsedRange.Copy
        xTempDoc.Content.PasteAndFormat wdFormatOriginalFormatting
        xTempDoc.SaveAs2 xPath & xWs.Name + ".docx", wdFormatXMLDocument
        xWb.Close False
        Kill xPath & xFileArr(I)
        xTempDoc.Close wdDoNotSaveChanges, wdOriginalDocumentFormat, False
    End If
Next
xExcel.DisplayAlerts = True
xExcel.Quit
xFileArr() = GetFiles(xPath)
'Merge Documents
For I = 0 To UBound(xFileArr()) - 1
    xExt = SplitPath(xFileArr(I), 2)
    If (xExt = ".docx") Or (xExt = ".doc") Or (xExt = ".docm") Or (xExt = ".dot") Or _
       (xExt = ".dotm") Or (xExt = ".dotx") Then
        MergeDoc xWdApp, xPath & xFileArr(I), xNewDoc
        Kill xPath & xFileArr(I)
    End If
Next
xNewDoc.Sections.Item(1).Range.Delete wdCharacter, 1
xNewDoc.SaveAs2 xPDFSavePath, wdFormatPDF
xNewDoc.Close wdDoNotSaveChanges, wdOriginalDocumentFormat, False
xWdApp.Quit
Set xMail = Nothing
Set xNameSpace = Nothing
Set xFSysObj = Nothing
MsgBox "Merged successfully", vbInformation + vbOKOnly
End Sub

Public Function SplitPath(FullPath As String, ResultFlag As Integer) As String
Dim SplitPos As Integer, DotPos As Integer
SplitPos = InStrRev(FullPath, "/")
DotPos = InStrRev(FullPath, ".")
Select Case ResultFlag
Case 0
   SplitPath = Left(FullPath, SplitPos - 1)
Case 1
   If DotPos = 0 Then DotPos = Len(FullPath) + 1
   SplitPath = Mid(FullPath, SplitPos + 1, DotPos - SplitPos - 1)
Case 2
   If DotPos = 0 Then DotPos = Len(FullPath)
   SplitPath = Mid(FullPath, DotPos)
Case Else
   Err.Raise vbObjectError + 1, "SplitPath Function", "Invalid Parameter!"
End Select
End Function
  
Function CleanFileName(StrText As String) As String
Dim xStripChars As String
Dim xLen As Integer
Dim I As Integer
xStripChars = "/\[]:=," & Chr(34)
xLen = Len(xStripChars)
StrText = Trim(StrText)
For I = 1 To xLen
StrText = Replace(StrText, Mid(xStripChars, I, 1), "")
Next
CleanFileName = StrText
End Function

Function GetFiles(xFldPath As String) As String()
On Error Resume Next
Dim xFile As String
Dim xFileArr() As String
Dim xArr() As String
Dim I, x As Integer
x = 0
ReDim xFileArr(1)
xFileArr(1) = xFldPath '& "\"
xFile = Dir(xFileArr(1) & "*.*")
Do Until xFile = ""
    x = x + 1
    xFile = Dir
Loop
ReDim xArr(0 To x)
x = 0
xFile = Dir(xFileArr(1) & "*.*")
Do Until xFile = ""
    xArr(x) = xFile
    x = x + 1
    xFile = Dir
Loop
GetFiles = xArr()
End Function

Sub MergeDoc(WdApp As Word.Application, xFileName As String, Doc As Document)
Dim xNewDoc As Document
Dim xSec As Section
    Set xNewDoc = WdApp.Documents.Open(filename:=xFileName, Visible:=False)
    Set xSec = Doc.Sections.Add
    xNewDoc.Content.Copy
    xSec.PageSetup = xNewDoc.PageSetup
    xSec.Range.PasteAndFormat wdFormatOriginalFormatting
    xNewDoc.Close
End Sub

3. Clique em Ferramentas > Referências para abrir a caixa de diálogo Referências. Marque as caixas Microsoft Excel Object Library, Microsoft Scripting Runtime e Microsoft Word Object Library e clique no botão OK. Veja a captura de tela:

the step 1 about saving email attachments as single pdf

4. Pressione a tecla F5 ou clique no botão Executar para rodar o código. Uma caixa de diálogo Salvar Como aparecerá, especifique uma pasta para salvar o arquivo, dê um nome ao arquivo PDF e clique no botão Salvar. Veja a captura de tela:

the step 2 about saving email attachments as single pdf

5. Em seguida, uma caixa de diálogo do Microsoft Outlook aparecerá, clique no botão OK.

the step 3 about saving email attachments as single pdf

Agora, o e-mail selecionado com todos os seus anexos foi salvo em um único arquivo PDF.

Observação: Este script VBA funciona apenas para anexos do Microsoft Word e Excel.

Salve facilmente e-mails selecionados em diferentes formatos de arquivos no Outlook:

Com a ferramenta Bulk Save do Kutools for Outlook, você pode facilmente salvar vários e-mails selecionados como arquivos individuais nos formatos HTML, TXT, documento do Word, arquivo CSV, bem como PDF no Outlook, conforme mostrado na captura de tela abaixo. Baixe agora a versão gratuita do Kutools for Outlook!

the step 1 about saving email attachments as single pdf

Artigos Relacionados:

Melhores Ferramentas de Produtividade para Office

Notícia de Última Hora: Kutools para Outlook Lança Versão Gratuita!

Experimente o novo Kutools para Outlook com mais de100 recursos incríveis! Clique para baixar agora!

🤖 Kutools AI : Utiliza tecnologia avançada de IA para gerenciar e-mails com facilidade, incluindo responder, resumir, otimizar, estender, traduzir e criar e-mails.

📧 Automação de E-mail: Resposta automática (Disponível para POP e IMAP)  /  Agendar Enviar Email  /  CC/BCC automático por Regra ao Enviar Email  /  Encaminhamento automático (Regra avançada)   /  Adicionar Saudação automaticamente   /  Dividir automaticamente Emails com múltiplos destinatários em Email individuais ...

📨 Gerenciamento de Email: Recallar Email  /  Bloquear emails fraudulentos por Assunto e outros critérios  /  Excluir Duplicado  /  Pesquisa Avançada  /  Organizar Pastas ...

📁 Anexos Pro: Salvar em Lote  /  Desanexar em Lote  /  Comprimir em Lote  /  Salvar automaticamente   /  Desanexar automaticamente  /  Auto Comprimir ...

🌟 Magia da Interface: 😊Mais emojis bonitos e legais   /  Notificações de emails importantes  /  Minimizar Outlook em vez de fechar ...

👍 Recursos de um clique: Responder a Todos com Anexos  /   Emails Anti-Phishing  /  🕘Exibir o fuso horário do remetente ...

👩🏼‍🤝‍👩🏻 Contatos e Calendário: Adicionar contato em lote dos Email selecionados  /  Dividir um Grupo de Contatos em grupos individuais  /  Remover lembrete de aniversário ...

Utilize o Kutools no idioma que preferir — disponível em Inglês, Espanhol, Alemão, Francês, Chinês e mais de40 outros!

Desbloqueie instantaneamente o Kutools para Outlook com um único clique. Não espere, baixe agora e aumente sua eficiência!

kutools for outlook features1 kutools for outlook features2

🚀 Download com um clique — Baixe todos os complementos de Office

Recomendado fortemente: Kutools para Office (5 em1)

Um clique para baixar cinco instaladores de uma vez — Kutools para Excel, Outlook, Word, PowerPoint e Office Tab Pro. Clique para baixar agora!

  • ✅ Comodidade em um clique: Baixe todos os cinco pacotes de instalação em uma única ação.
  • 🚀 Pronto para qualquer tarefa no Office: Instale os complementos que você precisa, quando precisar.
  • 🧰 Inclui: Kutools para Excel / Kutools para Outlook / Kutools para Word / Office Tab Pro / Kutools para PowerPoint