Συμβουλή: Άλλες γλώσσες μεταφράζονται από την Google. Μπορείτε να επισκεφθείτε το English έκδοση αυτής της σύνδεσης.
Σύνδεση
x
or
x
x
Κανε ΕΓΓΡΑΦΗ
x

or

Πώς να μετατρέψετε ή να αποθηκεύσετε μηνύματα ηλεκτρονικού ταχυδρομείου και συνημμένα σε ένα μόνο αρχείο PDF στο Outlook;

Αυτό το άρθρο μιλά για την αποθήκευση ενός μηνύματος ηλεκτρονικού ταχυδρομείου και όλων των συνημμένων σε αυτό σε ένα ενιαίο αρχείο PDF στο Outlook.

Μετατροπή ή αποθήκευση μηνυμάτων ηλεκτρονικού ταχυδρομείου και συνημμένων σε ένα μόνο αρχείο PDF με κώδικα VBA


Αποθηκεύστε εύκολα επιλεγμένα μηνύματα ηλεκτρονικού ταχυδρομείου ως μεμονωμένο αρχείο PDF ή διαφορετικά αρχεία μορφής στο Outlook:

Με την Αποθηκεύστε ως αρχείο χρησιμότητα του Kutools για το Outlook, μπορείτε εύκολα να αποθηκεύσετε πολλά επιλεγμένα μηνύματα ηλεκτρονικού ταχυδρομείου ως μεμονωμένο αρχείο μορφής HTML, αρχείο μορφής TXT, έγγραφο Word, αρχείο CSV καθώς και αρχείο PDF στο Outlook όπως παρουσιάστηκε παρακάτω.

Kutools για το Outlook: με περισσότερα από 40 εύχρηστα πρόσθετα του Outlook, δωρεάν να δοκιμάσετε χωρίς περιορισμούς σε 45 ημέρες. Λήψη και δοκιμή δωρεάν τώρα!

Kutools για το Outlook: 100 + Νέα προηγμένα εργαλεία για το Outlook.
Καρτέλα Office: Ενεργοποίηση επεξεργασίας καρτελών και περιήγησης στο Office, Ακριβώς όπως Chrome, Firefox, IE 8 / 9 / 10.
Κλασικό μενού: Φέρτε πίσω παλιά μενού και γραμμές εργαλείων σε Office 2007, 2010, 2013, 2016 και 2019.

Μετατροπή ή αποθήκευση μηνυμάτων ηλεκτρονικού ταχυδρομείου και συνημμένων σε ένα μόνο αρχείο PDF με κώδικα VBA

Κάντε ως εξής, για να αποθηκεύσετε τα μηνύματα ηλεκτρονικού ταχυδρομείου με όλα τα συνημμένα σε ένα μόνο αρχείο PDF στο Outlook.

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 Sub

3. κλικ Εργαλεία > αναφορές για να ανοίξετε το αναφορές κουτί διαλόγου. Ελεγξε το Βιβλιοθήκη αντικειμένων του Microsoft Excel, Runtime της Microsoft Scripting και Βιβλιοθήκη αντικειμένων του Microsoft Word και στη συνέχεια κάντε κλικ στο OK κουμπί. Δείτε το στιγμιότυπο οθόνης:

4. Πάτα το F5 ή κάντε κλικ στο τρέξιμο για να εκτελέσετε τον κώδικα. Μετά ένα Αποθήκευση ως εμφανίζεται το παράθυρο διαλόγου, καθορίστε ένα φάκελο για να αποθηκεύσετε το αρχείο, κατόπιν δώστε στο αρχείο PDF ένα όνομα και κάντε κλικ στο Αποθηκεύσετε κουμπί. Δείτε το στιγμιότυπο οθόνης:

5. Μετά ένα Microsoft Outlook το παράθυρο διαλόγου εμφανίζεται, κάντε κλικ στο OK κουμπί.

Τώρα το επιλεγμένο μήνυμα ηλεκτρονικού ταχυδρομείου με όλα τα συνημμένα του αποθηκεύεται σε ένα ενιαίο αρχείο PDF.

Note: Αυτή η δέσμη ενεργειών VBA λειτουργεί μόνο για συνημμένα Microsoft Word και Excel.


Σχετικά Άρθρα:



Kutools για το Outlook

Περισσότερες από τις προχωρημένες λειτουργίες 100 για Outlook 2010, 2013, 2016, 2019 και 365

πυροβολισμό οθόνης kutools για προοπτική μικροσκοπικό για banner 201812

περισσότερα Χαρακτηριστικά | Δωρεάν κατέβασμα | Μόνο $ 39.00 για εκατοντάδες λειτουργίες

Say something here...
symbols left.
You are guest ( Sign Up? )
or post as a guest, but your post won't be published automatically.
Loading comment... The comment will be refreshed after 00:00.
  • To post as a guest, your comment is unpublished.
    Peter · 9 months ago
    A fix that has worked for me is to have MergeDoc read as follows - note Word.Document

    Sub MergeDoc(WdApp As Word.Application, xFileName As String, Doc As Word.Document)
    Dim xNewDoc2 As Word.Document
    Dim xSec As Section

    Set xNewDoc2 = WdApp.Documents.Open(FileName:=xFileName, Visible:=False)
    Set xSec = Doc.Sections.Add
    xNewDoc2.Content.Copy
    xSec.PageSetup = xNewDoc2.PageSetup
    xSec.Range.PasteAndFormat wdFormatOriginalFormatting
    xNewDoc2.Close
    End Sub

    Peter
  • To post as a guest, your comment is unpublished.
    Peter · 9 months ago
    This looks very powerful and just what I am looking for right now.


    All is good, apart from I am having trouble passing the 'Doc as Document' to the Merge routine

    (NB have to replace On Error Resume Next with On Error GoTo 0 to catch the problem) -

    2 difficulties -
    1. Type Mismatch caused by xNewDoc in the merge-call at MergeDoc xWdApp, xPath & xFileArr(I), xNewDoc
    2. And/or Set xSec = Doc.Sections.Add won't compile

    - perhaps because the macro is being run from Outlook and not e.g. Word
    - perhaps because of some local issues at my end

    But very encouraging to have a structure and method to approach the problem
    Thank you.
  • To post as a guest, your comment is unpublished.
    Allan · 10 months ago
    BEAUTIFUL!! And what timing.

    I've been meaning to attempt this for a while now. I look forward to testing it out.

    Thank you