Thank you for that, at first it seemed that worked, but it isnt consistent, for some reason, on certain emails it causes Word to crash, the error usually comes at the line "oShape.LockAspectRatio = msoTrue"

This is code I have there currently

Sub SaveMessageAsPDF()
MapHDrive
       '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 lbl_Exit:
objitem = GetCurrentItem
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
    strfilename = strPath & Format(Date, "mmmm dd, yyyy") & "\" & 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