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

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

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

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

Faça o seguinte para salvar o e-mail com todos os anexos em um único arquivo PDF no Outlook.

1. Selecione um e-mail com anexos que você salvará em um único arquivo PDF e pressione o botão outro + F11 chaves para abrir o Microsoft Visual Basic para Aplicações janela.

2. No Microsoft Visual Basic para Aplicações janela, clique em inserção > Módulo. Em seguida, copie o código VBA abaixo para a janela Módulo.

Código VBA: Salve 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 Ferramentas > Referências para abrir o Referências caixa de diálogo. Verifica a Biblioteca de objetos do Microsoft Excel, Tempo de execução de scripts da Microsoft e Biblioteca de objetos do Microsoft Word caixas e clique no OK botão. Veja a imagem:

4. aperte o F5 ou clique no Execute botão para executar o código. Então uma Salvar como caixa de diálogo aparece, especifique uma pasta para salvar o arquivo, em seguida, dê um nome ao arquivo PDF e clique no botão Salvar botão. Veja a imagem:

5. Então um Microsoft Outlook caixa de diálogo aparece, por favor clique no OK botão.

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

Note: Este script VBA funciona apenas para anexos do Microsoft Word e Excel.

Artigos relacionados:

• Como usar o botão de comando para salvar a planilha ativa como um arquivo PDF no Excel?
• Como salvar uma planilha como arquivo PDF e e-mail como um anexo através do Outlook?
• Como salvar seleção ou pasta de trabalho inteira como PDF no Excel?

---

Melhores ferramentas de produtividade de escritório

Kutools for Outlook - Mais de 100 recursos poderosos para turbinar seu Outlook

🤖 Assistente de correio AI: E-mails profissionais instantâneos com magia de IA – um clique para respostas geniais, tom perfeito, domínio multilíngue. Transforme o envio de e-mails sem esforço! ...

📧 Automação de e-mail: Fora do escritório (disponível para POP e IMAP)  /  Agendar envio de e-mails  /  CC/BCC automático por regras ao enviar e-mail  /  Encaminhamento automático (regras avançadas)   /  Adicionar saudação automaticamente   /  Divida automaticamente e-mails de vários destinatários em mensagens individuais ...

📨 Gestão de E-mail: Lembre-se facilmente de e-mails  /  Bloquear e-mails fraudulentos por assuntos e outros  /  Apagar Emails Duplicados  /  Pesquisa Avançada  /  Consolidar pastas ...

📁 Anexos Pró: Salvar em lote  /  Desanexar lote  /  Comprimir em Lote  /  Salvamento automático   /  Desanexação Automática  /  Compressão automática ...

???? Interface Mágica: 😊Mais emojis bonitos e legais   /  Aumente a produtividade do seu Outlook com visualizações com guias  /  Minimize o Outlook em vez de fechar ...

???? Maravilhas com um clique: Responder a todos com anexos recebidos  /   E-mails antiphishing  /  🕘Mostrar fuso horário do remetente ...

👩🏼‍🤝‍👩🏻 Contatos e calendário: Adicionar contatos em lote de e-mails selecionados  /  Dividir um grupo de contatos em grupos individuais  /  Remover lembretes de aniversário ...

Sobre Características 100 Aguarde sua exploração! Clique aqui para descobrir mais.

Saiba Mais       Download grátis      Comprar