Save attachments with subject name

Hi, hoping this is a quick fix. I'm using this macro to save attachments as they arrive in to a mailbox. I'd like to attachments to include to subject as well as the document name. Is this possible?

Thanks

Code:

---

Sub FindFilesAndMove()    Dim MyFolder As String, MyFile As String, srchStr As String, DestFoldFull As String, FSO As Object, rCell As Range
    Dim DestFold As String
   
    Set FSO = CreateObject("Scripting.Filesystemobject")
    MyFolder = "Y:\accounts\Conv slips\" '<<< change to suit
    DestFold = "Y:\accounts\Conv slips\Completions packs\"
   
    For Each rCell In Range("A2:A" & Range("A" & Rows.Count).End(xlUp).Row).Cells
        MyFile = Dir(MyFolder)
        srchStr = rCell.Value
        DestFoldFull = DestFold & srchStr & "\"
        MkDir DestFoldFull
        Do While MyFile <> ""
            If InStr(MyFile, srchStr) Then
                FSO.MoveFile Source:=MyFolder & MyFile, Destination:=DestFoldFull & MyFile
            End If
        MyFile = Dir
        Loop
    Next rCell
End Sub

---

Your code doesn't appear to have anything to do with attachments?
If you want to save attachments from Outlook messages as they arrive and include the message subject, this may create issues relating to illegal filename characters, and in some cases excessive string length. However the following will correct the former and when run from a Rule to identify the messages to process, will save the message attachments to the named folder as they arrive in the inbox. I have included a test macro to test the code:

Code:

---

Option Explicit

Sub TestSaveAttachments()
Dim olMsg As MailItem
    On Error Resume Next
    Select Case Outlook.Application.ActiveWindow.Class
        Case olInspector
            Set olMsg = ActiveInspector.currentItem
        Case olExplorer
            Set olMsg = Application.ActiveExplorer.Selection.Item(1)
    End Select
    SaveAttachments olMsg
lbl_Exit:
    Exit Sub
End Sub

Public Sub SaveAttachments(olItem As MailItem)
'Graham Mayor - https://www.gmayor.com - Last updated - 26 May 2017
Dim olAttach As Attachment
Dim strFname As String
Dim strExt As String
Dim j As Long
Const strSaveFldr As String = "D:\Path\Attachments\" 'the folder to save the attachments

    CreateFolders strSaveFldr
    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 = olAttach.FileName
                strFname = CleanFileName(olItem.Subject & "_" & strFname)
                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
'An Outlook macro by Graham Mayor
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
'An Outlook macro by Graham Mayor
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
'An Outlook macro by Graham Mayor
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)
'An Outlook macro by Graham Mayor
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 CleanFileName(strFileName As String) As String
Dim arrInvalid() As String
Dim lng_Index As Long
    'Define illegal characters (by ASCII CharNum)
    arrInvalid = Split("9|10|11|13|34|42|47|58|60|62|63|92|124", "|")
    'Remove any illegal filename characters
    CleanFileName = strFileName
    For lng_Index = 0 To UBound(arrInvalid)
        CleanFileName = Replace(CleanFileName, Chr(arrInvalid(lng_Index)), Chr(95))
    Next lng_Index
lbl_Exit:
    Exit Function
End Function

---