Jak konwertować lub zapisywać wiadomości e-mail i załączniki w jednym pliku PDF w programie Outlook?

W tym artykule mowa o zapisywaniu wiadomości e-mail i wszystkich zawartych w niej załączników w jednym pliku PDF w programie Outlook.

Konwertuj lub zapisuj wiadomości e-mail i załączniki w jednym pliku PDF z kodem VBA

Konwertuj lub zapisuj wiadomości e-mail i załączniki w jednym pliku PDF z kodem VBA

Wykonaj następujące czynności, aby zapisać wiadomość e-mail ze wszystkimi załącznikami w jednym pliku PDF w programie Outlook.

1. Wybierz wiadomość e-mail z załącznikami, które zapiszesz w pojedynczym pliku PDF, a następnie naciśnij inny + F11 klawisze, aby otworzyć Microsoft Visual Basic for Applications okno.

2. w Microsoft Visual Basic for Applications okno, kliknij wstawka > Moduł. Następnie skopiuj poniższy kod VBA do okna Module.

Kod VBA: zapisz wiadomość e-mail i załącznik w jednym pliku 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. kliknij Tools > Referencje otworzyć Referencje Okno dialogowe. Sprawdź Biblioteka obiektów programu Microsoft Excel, Środowisko wykonawcze skryptów firmy Microsoft Microsoft i Biblioteka obiektów programu Microsoft Word pola, a następnie kliknij OK przycisk. Zobacz zrzut ekranu:

4. wciśnij F5 lub kliknij run przycisk, aby uruchomić kod. Następnie Zapisz jako pojawi się okno dialogowe, określ folder, w którym ma zostać zapisany plik, a następnie nadaj plikowi PDF nazwę i kliknij Zapisz przycisk. Zobacz zrzut ekranu:

5. Następnie a Microsoft Outlook pojawi się okno dialogowe, kliknij OK przycisk.

Teraz wybrana wiadomość e-mail ze wszystkimi załącznikami jest zapisywana w jednym pliku PDF.

Note: Ten skrypt VBA działa tylko dla załączników Microsoft Word i Excel.

Podobne artykuły:

• Jak używać przycisku polecenia, aby zapisać aktywny arkusz roboczy jako plik PDF w programie Excel?
• Jak zapisać arkusz roboczy jako plik PDF i wysłać go e-mailem jako załącznik za pośrednictwem programu Outlook?
• Jak zapisać zaznaczenie lub cały skoroszyt jako plik PDF w programie Excel?

---

Najlepsze narzędzia biurowe

Kutools dla programu Outlook - Ponad 100 zaawansowanych funkcji, które usprawnią Twoje perspektywy

🤖 Asystent poczty AI: Natychmiastowe profesjonalne e-maile z magią AI — genialne odpowiedzi jednym kliknięciem, doskonały ton, biegła znajomość wielu języków. Zmień e-mailing bez wysiłku! ...

📧 Automatyzacja poczty e-mail: Poza biurem (dostępne dla POP i IMAP)  /  Zaplanuj wysyłanie wiadomości e-mail  /  Automatyczne CC/BCC według reguł podczas wysyłania wiadomości e-mail  /  Automatyczne przewijanie (Zasady zaawansowane)   /  Automatyczne dodawanie powitania   /  Automatycznie dziel wiadomości e-mail od wielu odbiorców na pojedyncze wiadomości ...

📨 Zarządzanie e-mail: Łatwe przywoływanie e-maili  /  Blokuj oszukańcze wiadomości e-mail według tematów i innych  /  Usuń zduplikowane wiadomości e-mail  /  Wiecej opcji  /  Konsoliduj foldery ...

📁 Załączniki Pro: Zapisz zbiorczo  /  Odłącz partię  /  Kompresuj wsadowo  /  Automatyczne zapisywanie   /  Automatyczne odłączanie  /  Automatyczna kompresja ...

🌟 Magia interfejsu: 😊Więcej ładnych i fajnych emotikonów   /  Zwiększ produktywność programu Outlook dzięki widokom na kartach  /  Zminimalizuj program Outlook zamiast go zamykać ...

>> Cuda jednym kliknięciem: Odpowiedz wszystkim, dodając przychodzące załączniki  /   E-maile chroniące przed phishingiem  /  🕘Pokaż strefę czasową nadawcy ...

👩🏼‍🤝‍👩🏻 Kontakty i kalendarz: Grupowe dodawanie kontaktów z wybranych e-maili  /  Podziel grupę kontaktów na pojedyncze grupy  /  Usuń przypomnienia o urodzinach ...

O Cechy 100 Poczekaj na eksplorację! Kliknij tutaj, aby dowiedzieć się więcej.

Czytaj więcej       Darmowe pobieranie      Zakup