Hi Graham,

Your method works perfectly the 1st time I run the rule. Each subsequent time I send another email through it puts the attachments through to the subfolder but the attachments are not being saved out to the directory. I have put a message box at the start and end so I know the macro is being called.

Was this working for you when you sent a number of emails through.

Here is how I am using your full code.

Option Explicit
Public Sub Graham(item As Outlook.MailItem)


MsgBox "Macro started"


TestProcess


MsgBox "Macro ended"


End Sub




 
Sub SaveAttachments(olItem As MailItem)
     'An Outlook macro by Graham Mayor
    Dim olAttach As Attachment
    Dim strFname As String
    Dim strExt As String
    Dim sFileType As String
    Dim j As Long
    'Const strSaveFldr As String = "C:\Path\Attachments\" 'The folder to save the attachments
    Const strSaveFldr As String = "C:\Trade File\" 'The folder to save the attachments
    
    CreateFolders strSaveFldr
    On Error GoTo CleanUp
    If olItem.Attachments.Count > 0 Then
        For j = olItem.Attachments.Count To 1 Step -1
            Set olAttach = olItem.Attachments(j)
            sFileType = LCase(Right(olAttach.FileName, 4))
            Select Case sFileType
                 ' Add additional file types below
            Case ".csv", ".xls", "xlsx", ".pdf"
                strFname = olAttach.FileName
                strExt = Right(strFname, Len(strFname) - InStrRev(strFname, Chr(46)))
                strFname = FileNameUnique(strSaveFldr, strFname, strExt)
                olAttach.SaveAsFile strSaveFldr & strFname
                 'olAttach.Delete        'delete the attachment
            Case Else
            End Select
        Next j
        olItem.Save
    End If
CleanUp:
    Set olAttach = Nothing
    Set olItem = Nothing
lbl_Exit:
    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
 
Sub TestProcess()
     'An Outlook macro by Graham Mayor
    Dim olMsg As MailItem
    On Error Resume Next
    Set olMsg = ActiveExplorer.Selection.item(1)
    SaveAttachments olMsg
lbl_Exit:
    Exit Sub
End Sub