[Tasos]

Καλησπέρα Γιώργο!
Μπορεις να παραμετροποιήσεις σχεδόν τα πάντα στο Outlook.

Δες:

Option Explicit
Declare Function MakeSureDirectoryPathExists Lib "imagehlp.dll" ( _
                                             ByVal lpPath As String) As Long
                                            
Sub SaveMyAttachments(eID$)

Const xlFolder = "C:\ExcelAttachments\"
Const wdFolder = "C:\WordAttachments\"
Const dbFolder = "C:\DBAttachments\"
Const ppFolder = "C:\PPAttachments\"
Const SubjectText = "Reports"

    Dim oNewMail As MailItem, sfolder$, itm As Attachment, _
        Ext$, i%, msg$, AtsFilename$
    Set oNewMail = Application.Session.GetItemFromID(eID)
    msg = "Followed Attatchments have been moved to folder:" & vbCrLf
    With oNewMail
        If .Subject Like "*" & SubjectText & "*" Then  'ή If .Subject = SubjectText Then  (για ακριβή αντιστοίχιση)
            For i = .Attachments.Count To 1 Step -1
                Set itm = .Attachments(i)
                Ext = Right(itm.Filename, 4)
                If Ext Like "*" & "xl" & "*" Then
                    sfolder = xlFolder
                ElseIf Ext Like "*" & "doc" & "*" Then
                    sfolder = wdFolder
                ElseIf Ext Like "*" & "pp" & "*" Then
                    sfolder = ppFolder
                ElseIf Ext Like "*" & "db" & "*" Then
                    sfolder = dbFolder
                Else
                    sfolder = vbNullString
                End If
                If sfolder <> vbNullString Then
                    MakeSureDirectoryPathExists sfolder
                    AtsFilename = sfolder & "(" & Replace(Replace( _
                                  .CreationTime, ":", "_"), "/", "_") & ")_" & itm.Filename
                    itm.SaveAsFile AtsFilename
                    msg = msg & itm.Filename & " at: " & sfolder & vbCrLf
                    .Attachments.Remove itm.Index
                End If
            Next
            If sfolder <> vbNullString Then
                .Body = msg & vbCrLf & .Body
                .Save
            End If
        End If
    End With
End Sub

Καλή συνέχεια

Φιλικά
Τάσος