You can do it with the Office PDF function by employiing an Outlook Macro and a couple of useful functions to ensure duplicate filenames are not overwritten:
Code:
Option Explicit
Private wdApp As Object
Private wdDoc As Object
Private bStarted As Boolean
Const strPath As String = "C:\Path\Email Messages\"
Sub SaveSelectedMessagesAsPDF()
'Select the messages to process and run this macro
Dim olMsg As MailItem
'Create the folder to store the messages if not present
If CreateFolders(strPath) = False Then GoTo lbl_Exit
'Open or Create a Word object
On Error Resume Next
Set wdApp = GetObject(, "Word.Application")
If Err Then
Set wdApp = CreateObject("Word.Application")
bStarted = True
End If
On Error GoTo 0
For Each olMsg In Application.ActiveExplorer.Selection
SaveAsPDFfile olMsg
Next olMsg
lbl_Exit:
If bStarted Then wdApp.Quit
Set olMsg = Nothing
Set wdApp = Nothing
Exit Sub
End Sub
Sub SaveAsPDFfile(olItem As MailItem)
'Graham Mayor - http://www.gmayor.com - Last updated - 08 May 2018
Dim olNS As NameSpace
Dim fso As Object, TmpFolder As Object
Dim tmpPath As String
Dim strFileName As String
Dim strName As String
Dim oRegex As Object
Set olNS = Application.GetNamespace("MAPI")
Set fso = CreateObject("Scripting.FileSystemObject")
tmpPath = fso.GetSpecialFolder(2)
strName = "email_temp.mht"
tmpPath = tmpPath & "\" & strName
olItem.SaveAs tmpPath, 10
Set wdDoc = wdApp.Documents.Open(fileName:=tmpPath, _
AddToRecentFiles:=False, _
Visible:=False, _
Format:=7)
strFileName = olItem.Subject
Set oRegex = CreateObject("vbscript.regexp")
oRegex.Global = True
oRegex.Pattern = "[\/:*?""<>|]"
strFileName = Trim(oRegex.Replace(strFileName, "")) & ".pdf"
strFileName = FileNameUnique(strPath, strFileName, "pdf")
strFileName = strPath & strFileName
wdDoc.ExportAsFixedFormat OutputFileName:= _
strFileName, _
ExportFormat:=17, _
OpenAfterExport:=False, _
OptimizeFor:=0, _
Range:=0, _
From:=0, _
To:=0, _
Item:=0, _
IncludeDocProps:=True, _
KeepIRM:=True, _
CreateBookmarks:=0, _
DocStructureTags:=True, _
BitmapMissingFonts:=True, _
UseISO19005_1:=False
wdDoc.Close 0
If fso.FileExists(tmpPath) = True Then Kill tmpPath
lbl_Exit:
Set olNS = Nothing
Set olItem = Nothing
Set wdDoc = Nothing
Set oRegex = Nothing
Exit Sub
End Sub
Private Function CreateFolders(strPath As String) As Boolean
Dim strTempPath As String
Dim lngPath As Long
Dim vPath As Variant
vPath = Split(strPath, "\")
strPath = vPath(0) & "\"
For lngPath = 1 To UBound(vPath)
strPath = strPath & vPath(lngPath) & "\"
On Error GoTo err_Handler
If Not FolderExists(strPath) Then MkDir strPath
Next lngPath
CreateFolders = True
lbl_Exit:
Exit Function
err_Handler:
MsgBox "The path " & strPath & " is invalid!"
CreateFolders = False
Resume lbl_Exit
End Function
Private Function FileNameUnique(strPath As String, _
strFileName As String, _
strExtension As String) As String
Dim lngF As Long
Dim lngName As Long
lngF = 1
lngName = Len(strFileName) - (Len(strExtension) + 1)
strFileName = Left(strFileName, lngName)
Do While FileExists(strPath & strFileName & Chr(46) & strExtension) = True
strFileName = Left(strFileName, lngName) & "(" & lngF & ")"
lngF = lngF + 1
Loop
FileNameUnique = strFileName & Chr(46) & strExtension
lbl_Exit:
Exit Function
End Function
Private Function FolderExists(fldr) As Boolean
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
If (fso.FolderExists(fldr)) Then
FolderExists = True
Else
FolderExists = False
End If
lbl_Exit:
Set fso = Nothing
Exit Function
End Function
Private Function FileExists(filespec) As Boolean
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
If fso.FileExists(filespec) Then
FileExists = True
Else
FileExists = False
End If
lbl_Exit:
Set fso = Nothing
Exit Function
End Function