The quoted part of your macro refers to items that are not declared and/or not present so it is difficult to evaluate what you have presented. I have changed some variable names and put in some functions that allow the macro to run (and commented out parts that are missing, in particular the reference to H drive and the call to save the attachments, which function is not present and which refers to a variable that is not part of the macro).

I have tested the macro below and it does not crash here. The macro will also reduce the image size to the quoted dimensions, so that part of the code works. The PDF is saved in the folder

strPath = "C:\Path\" & Format(Date, " mmmm dd, yyyy\")
which is created if not present
CreateFolders strPath
If you want to use an H drive, you will have to establish whether that drive exists before running the code at the start of the macro 'SaveMessageAsPDF"
You can do that with
IF Not FolderExists("H:\") Then GoTo lbl_Exit
Option Explicit
Private strPath As String
Private wdApp As Object
Private wdDoc As Object
Private bStarted As Boolean

Sub SaveMessageAsPDF()
'MapHDrive
'Select the messages to process and run this macro
Dim olMsg As MailItem
    'Open or Create a Word object
    Set olMsg = ActiveExplorer.Selection.Item(1)
    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
    SaveAsPDFfile olMsg, wdApp
lbl_Exit:
    If bStarted Then wdApp.Quit
    Set wdApp = Nothing
    Exit Sub
End Sub

Sub SaveAsPDFfile(olItem As MailItem, wdApp As Object)
Dim FSO As Object, TmpFolder As Object
Dim tmppath As String
Dim strfilename As String
Dim strAttachPrefix As String
Dim strName As String
Dim oRegEx As Object
Dim oShape As Object
Dim oRng As Object
    '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.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)

    'Change Font color to black and resize images
    Set oRng = wdDoc.Range
    oRng.Font.Color = -587137025
    For Each oShape In oRng.InlineShapes
        With oShape
            oShape.LockAspectRatio = msoTrue
            If oShape.Width > wdApp.InchesToPoints(6.5) Then
                oShape.Width = wdApp.InchesToPoints(6.5)
            End If
        End With
    Next oShape


    'Create a file name from the message subject
    strfilename = InputBox("Enter claim number for message" & vbCr & _
                           olItem.Subject, "Claim Number")
    If strfilename = "" Then GoTo lbl_Exit


    '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")
    strAttachPrefix = Replace(strfilename, ".pdf", "")
    'save attachments
    'SaveAttachments olItem, strAttachPrefix
    strPath = "C:\Path\" & Format(Date, " mmmm dd, yyyy\")
    CreateFolders strPath
    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
lbl_Exit:
    wdDoc.Close 0
    Set wdDoc = Nothing
    Set oRegEx = Nothing
    Exit Sub
End Sub

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 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:
    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:
    Exit Function
End Function

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