If you want to add the subject then you are also going to have to check for illegal filename characters and I assume unique filenames so use the following instead
Option Explicit
Sub TestCode()
Dim olMsg As MailItem
On Error Resume Next
Set olMsg = ActiveExplorer.Selection.Item(1)
SaveAttachments olMsg
lbl_Exit:
Exit Sub
End Sub
Public Sub SaveAttachments(olItem As MailItem)
'Graham Mayor - https://www.gmayor.com - Last updated - 22 Jul 2019
Dim olAttach As Attachment
Dim strFname As String
Dim strExt As String
Dim j As Long, lng_Index As Long
Dim arrInvalid() As String
Const strSaveFldr As String = "D:\ServerReports\outlook-attachments\"
arrInvalid = Split("9|10|11|13|34|42|47|58|60|62|63|92|124", "|")
On Error Resume Next
If olItem.Attachments.Count > 0 Then
For j = 1 To olItem.Attachments.Count
Set olAttach = olItem.Attachments(j)
'If Not olAttach.fileName Like "image*.*" Then
strFname = olItem.Subject & "_" & olAttach.fileName
For lng_Index = 0 To UBound(arrInvalid)
strFname = Replace(strFname, Chr(arrInvalid(lng_Index)), Chr(95))
Next lng_Index
strExt = Right(strFname, Len(strFname) - InStrRev(strFname, Chr(46)))
strFname = FileNameUnique(strSaveFldr, strFname, strExt)
olAttach.SaveAsFile strSaveFldr & strFname
'End If
Next j
olItem.Save
End If
lbl_Exit:
Set olAttach = Nothing
Set olItem = Nothing
Exit Sub
End Sub
Private Function FileNameUnique(strPath As String, _
strFileName As String, _
strExtension As String) As String
'Graham Mayor - https://www.gmayor.com - Last updated - 22 Jul 2019
Dim lngF As Long
Dim lngName As Long
Dim fso As Object
lngF = 1
Set fso = CreateObject("Scripting.FileSystemObject")
lngName = Len(strFileName) - (Len(strExtension) + 1)
strFileName = Left(strFileName, lngName)
Do While fso.FileExists(strPath & strFileName & Chr(46) & strExtension) = True
strFileName = Left(strFileName, lngName) & "(" & lngF & ")"
lngF = lngF + 1
Loop
FileNameUnique = strFileName & Chr(46) & strExtension
lbl_Exit:
Set fso = Nothing
Exit Function
End Function