olAttach.SaveAsFile strSaveFldr & strFname
                olAttach.Delete        'delete the attachment
            End If

Option Explicit

Sub ProcessAttachment()
'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

Sub ProcessFolder()
'An Outlook macro by Graham Mayor
Dim olNS As Outlook.NameSpace
Dim olMailFolder As Outlook.MAPIFolder
Dim olItems As Outlook.Items
Dim olMailItem As Outlook.MailItem
Dim oFrm As New frmProgress
Dim PortionDone As Double
Dim i As Long

    On Error GoTo err_Handler
    Set olNS = GetNamespace("MAPI")
    Set olMailFolder = olNS.PickFolder
    Set olItems = olMailFolder.Items
    oFrm.Show vbModeless
    i = 0
    For Each olMailItem In olItems
        i = i + 1
        PortionDone = i / olItems.Count
        oFrm.lblProgress.Width = oFrm.fmeProgress.Width * PortionDone
        SaveAttachments olMailItem
        DoEvents
    Next olMailItem
err_Handler:
    Unload oFrm
    Set oFrm = Nothing
    Set olNS = Nothing
    Set olMailFolder = Nothing
    Set olItems = Nothing
    Set olMailItem = Nothing
lbl_Exit:
    Exit Sub
End Sub


Private Sub SaveAttachments(olItem As MailItem)
'An Outlook macro by Graham Mayor
Dim olAttach As Attachment
Dim strFname As String
Dim strExt As String
Dim j As Long
Const strSaveFldr As String = "D:\Path\Reports\"

    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)
            If Not olAttach.FileName Like "image*.*" Then
                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
            End If
        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

Const strSaveFldr As String = "D:\Path\Reports\"