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