如何在Outlook中将电子邮件和附件转换或保存为单个PDF文件？ |
您所在的位置：网站首页 › outlook导出邮件PDF › 如何在Outlook中将电子邮件和附件转换或保存为单个PDF文件？ |
如何在Outlook中将电子邮件和附件转换或保存为单个PDF文件？
|
如何在Outlook中将电子邮件和附件转换或保存为单个PDF文件？
本文讨论的是将电子邮件及其中的所有附件保存到Outlook中的单个PDF文件中。 使用VBA代码将电子邮件和附件转换或保存为单个PDF文件 使用VBA代码将电子邮件和附件转换或保存为单个PDF文件请执行以下操作以将电子邮件及其所有附件保存到Outlook中的单个PDF文件中。 1.选择带有附件的电子邮件，您将其保存到单个PDF文件中，然后按 其他 + F11 键打开 Microsoft Visual Basic应用程序 窗口。 2.在 Microsoft Visual Basic应用程序 窗口中，单击 插页 > 模块。 然后将下面的VBA代码复制到“模块”窗口中。 VBA代码：将电子邮件和附件保存到一个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 Sub3。 点击 工具 > 参考资料 打开 参考资料 对话框。 检查 Microsoft Excel对象库, Microsoft脚本运行时 和 Microsoft Word对象库 框，然后单击 OK 按钮。 看截图：
4。 按 F5 键或单击 运行 按钮运行代码。 然后一个 另存为 弹出对话框，请指定一个文件夹来保存文件，然后给PDF文件命名，然后单击 保存 按钮。 看截图：
5.然后 微软Outlook 弹出对话框，请点击 OK 按钮。
现在，所选电子邮件及其所有附件将保存到一个PDF文件中。 备注：此VBA脚本仅适用于Microsoft Word和Excel附件。 在Outlook中轻松将选定的电子邮件另存为不同格式的文件： 随着 批量保存 实用程序 Kutools for Outlook，您可以轻松地将多个选定的电子邮件另存为Outlook中的单个HTML格式文件，TXT格式文件，Word文档，CSV文件以及PDF文件，如下图所示。 立即下载并试用！ （60 天免费试用）
📧 电子邮件自动化: 外出（适用于 POP 和 IMAP） / 安排发送电子邮件 / 发送电子邮件时按规则自动抄送/密件抄送 / 自动转发（高级规则） / 自动添加问候语 / 自动将多收件人电子邮件拆分为单独的消息 ... 📨 电子邮件管理: 轻松回忆电子邮件 / 按主题和其他人阻止诈骗电子邮件 / 删除重复的电子邮件 / 高级搜索 / 合并文件夹 ... 📁 附件专业版: 批量保存 / 批量分离 / 批量压缩 / 自动保存 / 自动分离 / 自动压缩 ... 🌟 界面魔法: 😊更多又漂亮又酷的表情符号 / 使用选项卡式视图提高 Outlook 工作效率 / 最小化 Outlook 而不是关闭 ... 👍 一键奇迹: 使用传入附件回复全部 / 反网络钓鱼电子邮件 / 🕘显示发件人的时区 ... 👩🏼🤝👩🏻 通讯录和日历: 从选定的电子邮件中批量添加联系人 / 将联系人组拆分为各个组 / 删除生日提醒 ... 超过 100特点 等待您的探索！ 单击此处了解更多。
|
【本文地址】
今日新闻 |
推荐新闻 |