SaveMultipleEmailsAsOnePDF

Sub ExportMultipleOutlookEmails_AsOnePDFFile() Dim objSelection As Outlook.Selection Dim objFileSystem As Object Dim strTempFolder As String Dim objMail As Outlook.MailItem Dim strFileName As String Dim strFilePath As String Dim objWordApp As Word.Application Dim objTempWordDocument As Word.Document Dim strFile As String Dim strPDF As String 'Get all selected emails Set objSelection = Outlook.Application.ActiveExplorer.Selection If Not (objSelection Is Nothing) Then 'Create a temp folder Set objFileSystem = CreateObject("Scripting.FileSystemObject") strTempFolder = objFileSystem.GetSpecialFolder(2).Path & "\Temp" & Format(Now, "yyyymmddhhmmss") MkDir (strTempFolder) 'Save all emails as mht files in temp folder For Each objMail In objSelection strFileName = objMail.Subject strFileName = Replace(strFileName, "/", "-") strFileName = Replace(strFileName, "\", "-") strFileName = Replace(strFileName, ":", "-") strFileName = Replace(strFileName, "?", "-") strFileName = Replace(strFileName, Chr(34), "-") strFileName = Format(objMail.ReceivedTime, "yyyy-mm-dd") & " - " & strFileName & ".mht" strFilePath = strTempFolder & "\" & strFileName objMail.SaveAs strFilePath, olMHTML Next 'Create a temp Word document Set objWordApp = CreateObject("Word.Application") Set objTempWordDocument = objWordApp.Documents.Add 'Copy the contents of all mht files into the temp Word document strFile = Dir(strTempFolder & "\" & "*.mht") i = 0 While strFile <> "" i = i + 1 Set objWordRange = objTempWordDocument.Range With objWordRange .Collapse wdCollapseEnd If i > 1 Then .InsertBreak wdSectionBreakNextPage .End = objTempWordDocument.Range.End .Collapse wdCollapseEnd End If .InsertFile strTempFolder & "\" & strFile End With strFile = Dir() Wend 'Change the path to save the PDF file strPDF = "E:\Merged Emails.pdf" 'Export the temp Word document as a PDF file objTempWordDocument.ExportAsFixedFormat strPDF, wdExportFormatPDF 'Close & discard the temp Word document objTempWordDocument.Close False objWordApp.Quit 'Delete the temp folder objFileSystem.DeleteFolder (strTempFolder) MsgBox "Completed!" End If End Sub