Hi, I'm hoping someone can help me with something. I currently use this macro which saves attachments as they arrive in my inbox and saves them to a specific folder.
I'd like it changed so the attachments are saved and renamed with the email subject. Is this possible?

Thank you

Option Explicit

Sub SaveAttachments(olItem As MailItem)


Dim olAttach As Attachment
Dim strFname As String
Dim strExt As String
Dim j As Long
Const strSaveFldr As String = "Y:\accounts\Conv slips\"


    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
                olAttach.SaveAsFile strSaveFldr & strFname
                'olAttach.Delete        'delete the attachment
            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


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


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