Làm cách nào để chuyển đổi hoặc lưu email và tệp đính kèm vào một tệp PDF duy nhất trong Outlook?
Bài viết này nói về cách lưu một email và tất cả các tệp đính kèm trong đó vào một tệp PDF duy nhất trong Outlook.
Chuyển đổi hoặc lưu email và tệp đính kèm vào một tệp PDF duy nhất với mã VBA
Chuyển đổi hoặc lưu email và tệp đính kèm vào một tệp PDF duy nhất với mã VBA
Vui lòng thực hiện như sau để lưu email với tất cả các tệp đính kèm vào một tệp PDF duy nhất trong Outlook.
1. Chọn một email có tệp đính kèm mà bạn sẽ lưu vào một tệp PDF, rồi nhấn Khác + F11 phím để mở Microsoft Visual Basic cho các ứng dụng cửa sổ.
2. bên trong Microsoft Visual Basic cho các ứng dụng cửa sổ, nhấp Chèn > Mô-đun. Và sau đó sao chép mã VBA bên dưới vào cửa sổ Mô-đun.
Mã VBA: Lưu email và tệp đính kèm vào một tệp PDF duy nhất
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. nhấp chuột CÔNG CỤ > dự án để mở dự án hộp thoại. Kiểm tra Thư viện đối tượng Microsoft Excel, Thời gian chạy tập lệnh của Microsoft và Thư viện đối tượng Microsoft Word và sau đó nhấp vào OK cái nút. Xem ảnh chụp màn hình:
4. Nhấn nút F5 phím hoặc nhấp vào chạy để chạy mã. Sau đó a Save As hộp thoại bật lên, vui lòng chỉ định thư mục để lưu tệp, sau đó đặt tên cho tệp PDF và nhấp vào Lưu cái nút. Xem ảnh chụp màn hình:
5. Sau đó a Microsoft Outlook hộp thoại bật lên, vui lòng nhấp vào OK .
Giờ đây, email đã chọn với tất cả các tệp đính kèm được lưu vào một tệp PDF duy nhất.
Chú thích: Tập lệnh VBA này chỉ hoạt động cho các tệp đính kèm Microsoft Word và Excel.
Dễ dàng lưu các email đã chọn dưới dạng tệp định dạng khác nhau trong Outlook:
Với Lưu hàng loạt tiện ích của Kutools cho Outlook, bạn có thể dễ dàng lưu nhiều email đã chọn dưới dạng tệp định dạng HTML riêng lẻ, tệp định dạng TXT, tài liệu Word, tệp CSV cũng như tệp PDF trong Outlook như ảnh chụp màn hình bên dưới. Tải xuống và dùng thử ngay bây giờ! (đường mòn miễn phí 60 ngày)
Bài viết liên quan:
- Làm cách nào để sử dụng Nút lệnh để lưu trang tính đang hoạt động dưới dạng tệp PDF trong Excel?
- Làm cách nào để lưu trang tính dưới dạng tệp PDF và gửi qua email dưới dạng tệp đính kèm thông qua Outlook?
- Làm cách nào để lưu lựa chọn hoặc toàn bộ sổ làm việc dưới dạng PDF trong Excel?
Công cụ năng suất văn phòng tốt nhất
Kutools cho Outlook - Hơn 100 tính năng mạnh mẽ để tăng cường Outlook của bạn
📧 Tự động hoá email: Vắng Mặt (Có sẵn cho POP và IMAP) / Lên lịch gửi email / Tự động CC/BCC theo quy định khi gửi Email / Tự động chuyển tiếp (Quy tắc nâng cao) / Tự động thêm lời chào / Tự động chia email nhiều người nhận thành các tin nhắn riêng lẻ hữu ích. Cảm ơn !
📨 Quản lý email: Dễ dàng thu hồi email / Chặn email lừa đảo theo chủ đề và những người khác / Xóa các email trùng lặp / Tìm Kiếm Nâng Cao / Hợp nhất các thư mục hữu ích. Cảm ơn !
📁 Tệp đính kèm chuyên nghiệp: Lưu hàng loạt / Tách hàng loạt / Nén hàng loạt / Tự động lưu / Tự động tách / Tự động nén hữu ích. Cảm ơn !
🌟 Giao diện ma thuật: 😊Thêm nhiều biểu tượng cảm xúc đẹp và thú vị hơn / Tăng năng suất Outlook của bạn với chế độ xem theo thẻ / Thu nhỏ Outlook thay vì đóng hữu ích. Cảm ơn !
👍 Kỳ quan chỉ bằng một cú nhấp chuột: Trả lời tất cả bằng tệp đính kèm đến / Email chống lừa đảo / 🕘Hiển thị múi giờ của người gửi hữu ích. Cảm ơn !
👩🏼🤝👩🏻 Danh bạ & Lịch: Thêm hàng loạt liên hệ từ các email đã chọn / Chia nhóm liên hệ thành các nhóm riêng lẻ / Xóa lời nhắc sinh nhật hữu ích. Cảm ơn !
Trên 100 tính năng Chờ đợi sự khám phá của bạn! Bấm vào đây để khám phá thêm.