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

CreateFolders strPath        'Create the folder to store the messages if not present
    '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 wdApp = Nothing
    Exit Sub
End Sub

Sub SaveAsPDFfile(olItem As MailItem)
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")

    'Get the user's TempFolder to store the temporary file
    Set fso = CreateObject("Scripting.FileSystemObject")
    tmpPath = fso.GetSpecialFolder(2)

    'construct the filename for the temp mht-file
    strName = "email_temp.mht"
    tmpPath = tmpPath & "\" & strName

    'Save temporary file
    olItem.SaveAs tmpPath, 10
   
    'Open the temporary file in Word
    Set wdDoc = wdApp.Documents.Open(Filename:=tmpPath, _
                                     AddToRecentFiles:=False, _
                                     Visible:=False, _
                                     Format:=7)

    'Create a file name from the message subject
    strFileName = olItem.Subject
    'Remove illegal filename characters
    Set oRegEx = CreateObject("vbscript.regexp")
    oRegEx.Global = True
    oRegEx.Pattern = "[\/:*?""<>|]"
    strFileName = Trim(oRegEx.Replace(strFileName, "")) & ".pdf"
    strFileName = FileNameUnique(strPath, strFileName, "pdf")
    strFileName = strPath & strFileName

    'Save As pdf
    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

    ' close the document and Word
    wdDoc.Close
    'Cleanup
    Set olNS = Nothing
    Set olItem = Nothing
    Set wdDoc = Nothing
    Set oRegEx = Nothing
lbl_Exit:
    Exit Sub
End Sub

Private Function CreateFolders(strPath As String)
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) & "\"
        If Not FolderExists(strPath) Then MkDir strPath
    Next lngPath
lbl_Exit:
    Exit Function
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(ByVal PathName As String) As Boolean
Dim nAttr As Long
    On Error GoTo NoFolder
    nAttr = GetAttr(PathName)
    If (nAttr And vbDirectory) = vbDirectory Then
        FolderExists = True
    End If
NoFolder:
    Exit Function
End Function

Private Function FileExists(ByVal Filename As String) As Boolean
Dim nAttr As Long
    On Error GoTo NoFile
    nAttr = GetAttr(Filename)
    If (nAttr And vbDirectory) <> vbDirectory Then
        FileExists = True
    End If
NoFile:
    Exit Function
End Function