¿Cómo convertir o guardar correos electrónicos y archivos adjuntos en un solo archivo PDF en Outlook?
Este artículo habla sobre cómo guardar un mensaje de correo electrónico y todos los archivos adjuntos que contiene en un solo archivo PDF en Outlook.
Convierta o guarde el correo electrónico y los archivos adjuntos en un solo archivo PDF con código VBA
Haga lo siguiente para guardar el correo electrónico con todos sus archivos adjuntos en un solo archivo PDF en Outlook.
1. Seleccione un correo electrónico con archivos adjuntos que guardará en un solo archivo PDF y luego presione el otro + F11 teclas para abrir el Microsoft Visual Basic para aplicaciones ventana.
2. En el Microsoft Visual Basic para aplicaciones ventana, haga clic recuadro > Módulo. Y luego copie el siguiente código VBA en la ventana del Módulo.
Código VBA: guarde el correo electrónico y los archivos adjuntos en un solo archivo 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. Hacer clic en Herramientas > Referencias para abrir el Referencias caja de diálogo. Comprobar el Biblioteca de objetos de Microsoft Excel, Tiempo de ejecución de secuencias de comandos de Microsoft y Biblioteca de objetos de Microsoft Word cuadros y luego haga clic en el OK botón. Ver captura de pantalla:
4. presione el F5 o haga clic en el Ejecutar botón para ejecutar el código. Entonces un Guardar como aparece el cuadro de diálogo, especifique una carpeta para guardar el archivo, luego asigne un nombre al archivo PDF y haga clic en Guardar botón. Ver captura de pantalla:
5. Entonces un microsoft Outlook aparece el cuadro de diálogo, haga clic en el OK del botón.
Ahora, el correo electrónico seleccionado con todos sus archivos adjuntos se guarda en un solo archivo PDF.
Note: Este script de VBA solo funciona para archivos adjuntos de Microsoft Word y Excel.
Guarde fácilmente los correos electrónicos seleccionados como archivos de formato diferente en Outlook:
Con la Ahorro masivo utilidad de Kutools para Outlook, puede guardar fácilmente varios correos electrónicos seleccionados como archivo de formato HTML individual, archivo de formato TXT, documento de Word, archivo CSV y archivo PDF en Outlook, como se muestra a continuación. ¡Descárgalo y pruébalo ahora! (Pista gratuita de 60 días)
Artículos relacionados:
- ¿Cómo usar el botón de comando para guardar la hoja de trabajo activa como archivo PDF en Excel?
- ¿Cómo guardar una hoja de trabajo como archivo PDF y enviarla por correo electrónico como archivo adjunto a través de Outlook?
- ¿Cómo guardar la selección o el libro completo como PDF en Excel?
Las mejores herramientas de productividad de oficina
Kutools para Outlook - Más de 100 potentes funciones para potenciar tu perspectiva
🤖 Asistente de correo AI: Correos electrónicos profesionales instantáneos con magia de IA: respuestas geniales con un clic, tono perfecto y dominio multilingüe. ¡Transforme el correo electrónico sin esfuerzo! ...
📧 Automatización de correo electrónico: Fuera de la oficina (disponible para POP e IMAP) / Programar envío de correos electrónicos / CC/CCO automático según reglas al enviar correo electrónico / Reenvío automático (reglas avanzadas) / Agregar saludo automáticamente / Divida automáticamente correos electrónicos de múltiples destinatarios en mensajes individuales ...
📨 Gestión de correo electrónico: Recuperar correos electrónicos fácilmente / Bloquear correos electrónicos fraudulentos por sujetos y otras personas / Eliminar correos electrónicos duplicados / Búsqueda Avanzada / Consolidar carpetas ...
📁 Archivos adjuntos profesionales: Guardar lote / Separación de lotes / Comprimir por lotes / Ahorro automático / Desconexión automática / Autocompresión ...
???? Interfaz mágica: 😊Más emojis bonitos y geniales / Aumente su productividad en Outlook con vistas con pestañas / Minimizar Outlook en lugar de cerrar ...
👍 Maravillas con un clic: Responder a todos los archivos adjuntos entrantes / Correos electrónicos antiphishing / 🕘Mostrar zona horaria del remitente ...
👩🏼🤝👩🏻 Contactos y calendario: Agregar por lotes contactos de correos electrónicos seleccionados / Dividir un grupo de contactos en grupos individuales / Eliminar recordatorios de cumpleaños ...
Mas de Características 100 ¡Espere su exploración! Haga clic aquí para descubrir más.