Save attachments with subject name

[leemcder]

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


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

[gmayor]

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:

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