Як перетворити або зберегти електронну пошту та вкладення в один файл PDF у програмі Outlook?
У цій статті йдеться про збереження повідомлення електронної пошти та всіх вкладень у ньому до одного файлу PDF у програмі Outlook.
Перетворіть або збережіть електронну пошту та вкладення в один файл PDF із кодом VBA
Перетворіть або збережіть електронну пошту та вкладення в один файл PDF із кодом VBA
Виконайте наступні дії, щоб зберегти електронну пошту з усіма вкладеннями до одного файлу PDF у програмі Outlook.
1. Виберіть електронний лист із вкладеннями, які ви збережете в одному файлі PDF, а потім натисніть інший + F11 ключі, щоб відкрити Microsoft Visual Basic для додатків вікна.
2 В Microsoft Visual Basic для додатків вікна, натисніть Insert > Модулі. А потім скопіюйте наведений нижче код 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 Sub
3. клацання Tools > посилання відкрити посилання діалогове вікно. Перевірте Бібліотека об’єктів Microsoft Excel, Виконання сценаріїв Microsoft та Бібліотека об’єктів Microsoft Word а потім клацніть на OK кнопку. Дивіться знімок екрана:
4 Натисніть кнопку F5 або клацніть на прогін для запуску коду. Тоді a Зберегти як спливає діалогове вікно, вкажіть папку для збереження файлу, надайте файлу PDF ім'я та натисніть зберегти кнопку. Дивіться знімок екрана:
5. Тоді a Microsoft Перспективи з'явиться діалогове вікно, клацніть на OK кнопки.
Тепер вибраний електронний лист із усіма вкладеннями зберігається в одному файлі PDF.
примітки: Цей сценарій VBA працює лише для вкладень Microsoft Word та Excel.
Легко зберігайте вибрані електронні листи як різні формати у програмі Outlook:
З Масове збереження корисність Kutools для Outlook, Ви можете легко зберегти кілька вибраних листів як окремий файл формату HTML, файл формату TXT, документ Word, файл CSV, а також файл PDF у програмі Outlook, як показано нижче. Завантажте та спробуйте зараз! (60 днів безкоштовно)
Статті по темі:
- Як за допомогою кнопки команди зберегти активний аркуш як файл PDF у програмі Excel?
- Як зберегти аркуш як файл PDF та надіслати його електронною поштою як вкладення через Outlook?
- Як зберегти виділення або всю книгу у форматі PDF у Excel?
Найкращі інструменти продуктивності офісу
Kutools для Outlook - Понад 100 потужних функцій, які покращать ваш Outlook
???? Автоматизація електронної пошти: Поза офісом (доступно для POP та IMAP) / Розклад надсилання електронних листів / Автоматична копія/прихована копія за правилами під час надсилання електронної пошти / Автоматичне пересилання (розширені правила) / Автоматично додавати привітання / Автоматично розділяйте електронні листи кількох одержувачів на окремі повідомлення ...
📨 Управління електронною поштою: Легко відкликайте електронні листи / Блокуйте шахрайські електронні листи за темами та іншими / Видалити повторювані електронні листи / розширений пошук / Консолідація папок ...
📁 Вкладення Pro: Пакетне збереження / Пакетне від'єднання / Пакетний компрес / Автозавантаження / Автоматичне від'єднання / Автокомпресія ...
???? Магія інтерфейсу: 😊Більше красивих і класних смайликів / Підвищте продуктивність Outlook за допомогою вкладок / Згорніть Outlook замість того, щоб закривати ...
👍 Дива в один клік: Відповісти всім із вхідними вкладеннями / Антифішингові електронні листи / 🕘Показувати часовий пояс відправника ...
👩🏼🤝👩🏻 Контакти та календар: Пакетне додавання контактів із вибраних електронних листів / Розділіть групу контактів на окремі групи / Видаліть нагадування про день народження ...
більше Особливості 100 Чекайте на ваше дослідження! Натисніть тут, щоб дізнатися більше.