While it is not especially difficult to add the extraction of attachments to my earlier macro set, saving the attachments with the same name presents something of a problem. If you want to associate the attachments with the message, then you can use the account number, input from your inputbox as a prefix to the attachment names. I would also suggest putting the attachments in a sub folder as in the following example, which calls the extraction routine from the save to PDF function.

Frankly I don't see any advantage in using the input box, and if the account number is going to be in the subject anyway, then any prompt for a name you already have is a distraction, but I have included it.

Option Explicit
Private wdApp As Object
Private wdDoc As Object
Private bStarted As Boolean
Const strPath As String = "H:\Uploads\"

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 lbl_Exit:
    For Each olMsg In Application.ActiveExplorer.Selection
        SaveAsPDFfile olMsg, wdApp
    Next olMsg
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

    '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 = InputBox("Enter account number for message" & vbCr & _
    olItem.Subject, "Account 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 & 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 Sub SaveAttachments(olItem As MailItem, strName As String)
Dim olAttach As Attachment
Dim strFname As String
Dim strExt As String
Dim strSaveFldr As String
    
    strSaveFldr = strPath & "Attachments\"
    CreateFolders strSaveFldr
    On Error GoTo lbl_Exit
    If olItem.Attachments.Count > 0 Then
        For Each olAttach In olItem.Attachments
            If Not olAttach.Filename Like "image*.*" Then
                strFname = strName & "_" & olAttach.Filename
                strExt = Right(strFname, Len(strFname) - InStrRev(strFname, Chr(46)))
                strFname = FileNameUnique(strSaveFldr, strFname, strExt)
                olAttach.SaveAsFile strSaveFldr & strFname
            End If
        Next olAttach
    End If
lbl_Exit:
    Set olAttach = 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(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