In that case run the following script 'CustomSaveAttachments' from your rule. Change the path '"\\NetworkName\backup\Attachments"' to the location where you want to create the sub folders. The macro will create a subfolder as requested (and the additional folders in the path that are required) if they are not present and save any Excel XLSX files attached to that folder. Use the test macro with an existing message to test it.
Option Explicit
Sub Test()
Dim olMsg As MailItem
On Error Resume Next
Set olMsg = ActiveExplorer.Selection.Item(1)
CustomSaveAttachments olMsg
lbl_Exit:
Exit Sub
End Sub
Public Sub CustomSaveAttachments(Item As Outlook.MailItem)
Const strPath As String = "\\ServerName\backup\Attachments\" 'The root path
Dim olAtt As Attachment
Dim strFileName As String
Dim strSavePath As String
If Item.Attachments.Count > 0 Then
For Each olAtt In Item.Attachments
If olAtt.fileName Like "*.xlsx" Then
strSavePath = Item.Subject
strSavePath = Replace(strSavePath, "**actie**: ", "") 'optional
strSavePath = CleanFileName(strSavePath)
strSavePath = strPath & strSavePath & "\"
CreateFolders strSavePath
strFileName = FileNameUnique(strSavePath, olAtt.fileName, "xlsx")
strFileName = strSavePath & strFileName
olAtt.SaveAsFile strFileName
End If
Next olAtt
End If
lbl_Exit:
Exit Sub
End Sub
Private Function CreateFolders(strPath As String)
'Graham Mayor - http://www.gmayor.com - Last updated - 31 May 2017
'Creates the full path 'strPath' if missing or incomplete
Dim strTempPath As String
Dim lngPath As Long
Dim VPath As Variant
Dim oFSO As Object
Dim i As Integer
Set oFSO = CreateObject("Scripting.FileSystemObject")
VPath = Split(strPath, "\")
If Left(strPath, 2) = "\\" Then
strPath = "\\" & VPath(2) & "\"
For lngPath = 3 To UBound(VPath)
strPath = strPath & VPath(lngPath) & "\"
If Not oFSO.FolderExists(strPath) Then MkDir strPath
Next lngPath
Else
strPath = VPath(0) & "\"
For lngPath = 1 To UBound(VPath)
strPath = strPath & VPath(lngPath) & "\"
If Not oFSO.FolderExists(strPath) Then MkDir strPath
Next lngPath
End If
lbl_Exit:
Set oFSO = Nothing
Exit Function
End Function
Private Function CleanFileName(strFileName As String) As String
Dim arrInvalid() As String
Dim lng_Index As Long
'Define illegal characters (by ASCII CharNum)
arrInvalid = Split("9|10|11|13|34|42|47|58|60|62|63|92|124", "|")
'Remove any illegal filename characters
CleanFileName = strFileName
For lng_Index = 0 To UBound(arrInvalid)
CleanFileName = Replace(CleanFileName, Chr(arrInvalid(lng_Index)), Chr(95))
Next lng_Index
lbl_Exit:
Exit Function
End Function
Private Function FileNameUnique(strPath As String, _
strFileName As String, _
strExtension As String) As String
'Graham Mayor - http://www.gmayor.com - Last updated - 22 Jun 2018
'strPath is the path in which the file is to be saved
'strFilename is the filename to check
'strextension is the extension of the filename to check
Dim lng_F As Long
Dim lng_Name As Long
Dim FSO As Object
Set FSO = CreateObject("Scripting.FileSystemObject")
strExtension = Replace(strExtension, Chr(46), "")
lng_F = 1
lng_Name = Len(strFileName) - (Len(strExtension) + 1)
strFileName = Left(strFileName, lng_Name)
'If the filename exists, add or increment a number to the filename
'and keep checking until a unique name is found
Do While FSO.FileExists(strPath & strFileName & Chr(46) & strExtension) = True
strFileName = Left(strFileName, lng_Name) & "(" & lng_F & ")"
lng_F = lng_F + 1
Loop
'Reassemble the filename
FileNameUnique = strFileName & Chr(46) & strExtension
lbl_Exit:
Set FSO = Nothing
Exit Function
End Function