Add "Save attachment as subject" into script

[adrian123]

GRAHAM - Thank you for the script - unfortunatly If I am running your previous sctript with folder selection it is working fine. - If I am using the new one it does not do anything. I just modified the path to match my one. If I am running it there is no any message nothing, no saved files at all - in all cases attached files are .pdf. In rule manager I can correctly pick up the Scipt so I can see the name of it. Do you have any idea why it is not saving any fiels?

Thank you in advance

Sub Save_As_Subject(olItem As MailItem) 
    Dim olAttach As Attachment
    Dim strFileName As String
    Dim strExt As String
    Const strPath = "C:\Path\Attachments\" 'the path to store the files     
    For Each olAttach In olItem.Attachments
        strExt = Mid(olAttach.FileName, InStrRev(olAttach.FileName, Chr(46)))
        Select Case LCase(strExt)
        Case Is = ".docx", ".dotx", ".pdf", ".xlsx", ".zip" 'the wanted extensions
            strFileName = olItem.Subject
            strFileName = CleanFileName(strFileName)
            strFileName = strPath & strFileName & strExt
            olAttach.SaveAsFile strFileName
        Case Else
        End Select
    Next olAttach
    lbl_Exit:
    Set olItem = Nothing
    Set olAttach = Nothing
    Exit Sub
End Sub
 
Private Function CleanFileName(strFileName As String) As String    
    Dim arrInvalid() As String
    Dim vfName As Variant
    Dim lng_Name As Long
    Dim lng_Ext As Long
    Dim lngIndex As Long
    CleanFileName = strFileName
     'Define illegal characters (by ASCII CharNum)
    arrInvalid = Split("9|10|11|13|34|42|47|58|60|62|63|92|124", "|")
     'Add the extension to the filename
    CleanFileName = CleanFileName
     'Remove any illegal filename characters
    For lngIndex = 0 To UBound(arrInvalid)
        CleanFileName = Replace(CleanFileName, Chr(arrInvalid(lngIndex)), Chr(95))
    Next lngIndex
    lbl_Exit:
    Exit Function
End Function