كيفية تحويل أو حفظ البريد الإلكتروني والمرفقات في ملف PDF واحد في Outlook؟

تتحدث هذه المقالة عن حفظ رسالة بريد إلكتروني وجميع المرفقات بداخلها في ملف PDF واحد في Outlook.

قم بتحويل أو حفظ البريد الإلكتروني والمرفقات إلى ملف PDF واحد برمز VBA

قم بتحويل أو حفظ البريد الإلكتروني والمرفقات إلى ملف PDF واحد برمز VBA

يرجى القيام بما يلي لحفظ البريد الإلكتروني مع جميع مرفقاته في ملف PDF واحد في Outlook.

1. حدد بريدًا إلكترونيًا يحتوي على مرفقات ستحفظها في ملف PDF واحد ، ثم اضغط على قديم + F11 مفاتيح لفتح ميكروسوفت فيسوال باسيك للتطبيقات نافذة.

2. في ال ميكروسوفت فيسوال باسيك للتطبيقات الإطار، انقر فوق إدراج > وحدة. ثم انسخ كود فبا أدناه في نافذة الوحدة النمطية.

كود فبا: احفظ البريد الإلكتروني والمرفق في ملف 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, وقت تشغيل البرمجة لـ Microsoft و مكتبة كائنات Microsoft Word مربعات ثم انقر فوق OK زر. انظر لقطة الشاشة:

4. اضغط على F5 مفتاح أو انقر فوق يجري زر لتشغيل الكود. ثم حفظ باسم ينبثق مربع الحوار ، يرجى تحديد مجلد لحفظ الملف ، ثم تسمية ملف PDF والنقر فوق حفظ زر. انظر لقطة الشاشة:

5. ثم أ مايكروسوفت أوتلوك ينبثق مربع الحوار ، الرجاء النقر فوق OK .

الآن يتم حفظ البريد الإلكتروني المحدد مع جميع مرفقاته في ملف PDF واحد.

ملاحظات: هذا البرنامج النصي VBA يعمل فقط لمرفقات Microsoft Word و Excel.

مقالات ذات صلة:

• كيفية استخدام زر الأمر لحفظ ورقة العمل النشطة كملف PDF في Excel؟
• كيفية حفظ ورقة العمل كملف PDF وإرسالها بالبريد الإلكتروني كمرفق من خلال Outlook؟
• كيفية حفظ التحديد أو المصنف بأكمله كملف PDF في Excel؟

---

أفضل أدوات إنتاجية المكتب

كوتولس لتوقعات - أكثر من 100 ميزة قوية لتعزيز توقعاتك

🤖 مساعد بريد الذكاء الاصطناعي: رسائل بريد إلكتروني احترافية فورية مع سحر الذكاء الاصطناعي - بنقرة واحدة للردود العبقرية، والنغمة المثالية، وإتقان متعدد اللغات. تحويل البريد الإلكتروني دون عناء! ...

📧 أتمتة البريد الإلكتروني: خارج المكتب (متوفر لـ POP وIMAP)  /  جدولة إرسال رسائل البريد الإلكتروني  /  نسخة تلقائية/نسخة مخفية الوجهة حسب القواعد عند إرسال البريد الإلكتروني  /  إعادة التوجيه التلقائي (القواعد المتقدمة)   /  إضافة تحية تلقائية   /  تقسيم رسائل البريد الإلكتروني متعددة المستلمين تلقائيًا إلى رسائل فردية 

📨 إدارة البريد الإلكتروني: استدعاء رسائل البريد الإلكتروني بسهولة  /  حظر رسائل البريد الإلكتروني الاحتيالية حسب الموضوعات والآخرين  /  حذف رسائل البريد الإلكتروني المكررة  /  المزيد من خيارات البحث  /  توحيد المجلدات 

📁 المرفقات برو: حفظ دفعة  /  فصل دفعة  /  ضغط دفعة  /  حفظ تلقائي   /  فصل تلقائي  /  ضغط تلقائي 

؟؟؟؟ واجهة ماجيك: 😊 المزيد من الرموز التعبيرية الجميلة والرائعة   /  عزز إنتاجية Outlook الخاص بك باستخدام طرق العرض المبوبة  /  تصغير Outlook بدلاً من الإغلاق 

؟؟؟؟ بنقرة واحدة عجائب: الرد على الكل بالمرفقات الواردة  /   رسائل البريد الإلكتروني لمكافحة التصيد  /  🕘إظهار المنطقة الزمنية للمرسل 

👩🏼‍🤝‍👩🏻 جهات الاتصال والتقويم: دفعة إضافة جهات الاتصال من رسائل البريد الإلكتروني المحددة  /  تقسيم مجموعة اتصال إلى مجموعات فردية  /  إزالة تذكير عيد ميلاد 

على مدى ميزات 100 في انتظار الاستكشاف الخاص بك! انقر هنا لاكتشاف المزيد.

تفاصيل أكثر       تحميل مجانا      شراء