This is just a variation of a macro to save attachments, which I have posted here before. The only issue is that the workbooks you want to save are categorized with 'Supplier' or 'Customer'. In order to get the category you must first save the attachment, so the following saves to the User's temporary file location in order to evaluate the categories, using a simple function to read the categories from the file. Then depending on the category the process moves the file to the required folder or a 'No Category' folder (each of which it creates if not present - assuming the Z drive is avalable). Existing files of the same name in the target folders are not overwritten, but a number is appended.
The main 'SaveAttachments' macro can be run from a script associated with a Rule, or by using one of the supplementary macros run on a folder full of messages - 'ProcessFolder', or run on an individually selected message - 'ProcessAttachment' (which you can use to test the process).
Option Explicit
Sub ProcessAttachment()
'An Outlook macro by Graham Mayor www.gmayor.com
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 www.gmayor.com
Dim olAttach As Attachment
Dim strFname As String
Dim strExt As String
Dim j As Long
Dim strTempFldr As String: strTempFldr = Environ("Temp") & Chr(92)
Dim strSaveFldr As String
On Error GoTo lbl_Exit
If olItem.Attachments.Count > 0 Then
For j = olItem.Attachments.Count To 1 Step -1
Set olAttach = olItem.Attachments(j)
strFname = olAttach.FileName
strExt = Mid(strFname, InStrRev(strFname, Chr(46)) + 1)
Select Case strExt
Case Is = "xls", "xlsx", "xlsm"
olAttach.SaveAsFile strTempFldr & strFname
Select Case GetProperties(strFname)
Case "Supplier"
strSaveFldr = "Z:\Supplier\"
CreateFolders strSaveFldr
Name strTempFldr & strFname As strSaveFldr & FileNameUnique(strSaveFldr, strFname, strExt)
Case "Customer"
strSaveFldr = "Z:\Customer\"
CreateFolders strSaveFldr
Name strTempFldr & strFname As strSaveFldr & FileNameUnique(strSaveFldr, strFname, strExt)
Case Else
strSaveFldr = "Z:\No Category\"
CreateFolders strSaveFldr
Name strTempFldr & strFname As strSaveFldr & FileNameUnique(strSaveFldr, strFname, strExt)
End Select
End Select
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 www.gmayor.com
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 www.gmayor.com
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 www.gmayor.com
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 GetProperties(strFilename As String) As String
'An Outlook macro by Graham Mayor www.gmayor.com
Dim sFile As Variant
Dim oShell As Object: Set oShell = CreateObject("Shell.Application")
Dim oDir As Object: Set oDir = oShell.NameSpace(Environ("Temp") & Chr(92))
Dim i As Long
For Each sFile In oDir.Items
If sFile = strFilename Then
For i = 0 To 40
If oDir.GetDetailsOf(oDir.Items, i) = "Categories" Then
GetProperties = oDir.GetDetailsOf(sFile, i)
Exit For
End If
Next i
Exit For
End If
Next sFile
lbl_Exit:
Set oShell = Nothing
Set sFile = Nothing
Set oDir = Nothing
Exit Function
End Function