Sub SalvaAttachMailCorrente()
Dim OKName As Boolean
Dim NomeFolgi
Dim Stringa As String
Dim Exten As String
Dim myOlSel
Dim outapp
Dim Allegati

Set outapp = CreateObject("Outlook.application")
Set myOlSel = outapp.ActiveExplorer.Selection
If myOlSel.Count = 1 Then
    
    If myOlSel.Item(1).Attachments.Count = 0 Then
        MsgBox "il file non Ha allegati"
        Exit Sub
    Else
        For Allegati = 1 To myOlSel.Item(1).Attachments.Count
            Stringa = myOlSel.Item(1).Attachments.Item(Allegati).Filename
            'Exten = Right(Stringa, 3)
            'Stringa = Left(Stringa, Len(Stringa) - 4)
            Stringa = Application.GetSaveAsFilename(Stringa)
            Stringa = Stringa
            myOlSel.Item(1).Attachments.Item(Allegati).SaveAsFile Stringa
        Next
    End If
Else
    MsgBox "Selezione errata (nessun oggetto selezionato o selezione maggiore di 1)"
End If
Set outapp = Nothing
Set myOlSel = Nothing

End Sub

 Private Sub Workbook_Open()
Application.OnTime TimeValue("17:00:00"), "my_Procedure"
End Sub

Sub SalvaAttachMailCorrente()

Dim OKName As Boolean

Dim Stringa As String

Dim myOlSel

Dim outapp

Dim Allegati

Set outapp = CreateObject("Outlook.application")

Set myOlSel = outapp.ActiveExplorer.Selection

If myOlSel.Count = 1 Then
    
        For Allegati = 1 To myOlSel.Item(1).Attachments.Count
            Stringa = myOlSel.Item(1).Attachments.Item(Allegati).FileName
            Stringa = Application.GetSaveAsFilename(Stringa)
            Stringa = Stringa
            myOlSel.Item(1).Attachments.Item(Allegati).SaveAsFile Stringa
        Next
End If

Set outapp = Nothing
Set myOlSel = Nothing

End Sub

Stringa = myOlSel.Item(1).Attachments.Item(Allegati).FileName
myOlSel.Item(1).Attachments.Item(Allegati).SaveAsFile path & Stringa

Sub SalvaAttachMailCorrente3()

' in questa parte qui sotto vengono dichiarate le variabile
' quelle senza la parte as XXXX sono object
Dim Stringa As String
Dim myOlSel
Dim outapp
Dim Allegati
Dim Miopath As String


Set outapp = CreateObject("Outlook.application")
'assegno alla variabile outapp l'oggetto di outlook
Set myOlSel = outapp.ActiveExplorer.Selection
'assegno alla variabile myOlSel la selezione corrente di outlook

If myOlSel.Count = 1 Then
'l'istruzione serve per verificare se ho selezionato solo una mail
        For Allegati = 1 To myOlSel.Item(1).Attachments.Count
        'i cicli For fanno eseguire tutte le istruzione fino a next un certo numero di volte
        ' ne nostro caso eseguo da 1 fino al numero di allegati myOlSel.Item(1).Attachments.Count
        ' myOlSel.Item(1).Attachments.Count è il numero (count) di allaegati (attachments) del primo elemento (Item(1)) della selezione corrente
            Stringa = myOlSel.Item(1).Attachments.Item(Allegati).Filename
            ' assegno a stringa il nome del file in allegato
            Miopath = "C:ALLEGATI"
            ' assegno a Miopath il nome costante della directory
            myOlSel.Item(1).Attachments.Item(Allegati).SaveAsFile Miopath & Stringa
            ' salvo l'allegato
        Next
        'finisco il ciclo for
End If
'finisco l'if
Set outapp = Nothing
'annulla l'attribuazione alla variabile
Set myOlSel = Nothing
'annulla l'attribuazione alla variabile
End Sub

Sub SalvaAttachMailCorrente3()

Dim Stringa As String
Dim myOlSel
Dim outapp
Dim Allegati
Dim Miopath As String

Set outapp = CreateObject("Outlook.application")
Set myOlSel = outapp.ActiveExplorer.Selection

For Allegati = 1 To myOlSel.Item(1).Attachments.Count
            Stringa = myOlSel.Item(1).Attachments.Item(Allegati).FileName
            Miopath = "C:ALLEGATI"
            myOlSel.Item(1).Attachments.Item(Allegati).SaveAsFile Miopath & Stringa
Next
End Sub

Sub SalvaAttachMailCorrente4()

Dim Stringa As String
Dim Outapp
Dim myOlFolders
Dim MyFolder
Dim MyMail

Dim MioPath As String

MioPath = "C:UsersXXXXXYYYYYYMiaDir"

Set Outapp = CreateObject("Outlook.application")
Set myOlFolders = Outapp.session.Folders
Set MyFolder = Outapp.session.Folders("aaaaaa.bbbbb@xxxxxx.com").Folders("Inbox").Folders("Prova")
For Each MyMail In MyFolder.items
    If TypeName(MyMail) = "MailItem" Then
        Stringa = MyMail.Subject
        Stringa = Right(Stringa, 10)
        If Right(Stringa, 10) = Format(Date, "dd/mm/yyyy") Then
            With MyMail.Attachments.Item(1)
                .SaveAsFile MioPath & .DisplayName
            End With
        Else
        End If
    Else
    End If
Next
End Sub

Set fs = CreateObject("Scripting.FileSystemObject")
FileMio= fs.GetFile(percorsofile)
FileMio.Delete

Sub SalvaAttachMailCorrente4()
' definizione delle Variabili
Dim Stringa As String
Dim Outapp
Dim myOlFolders
Dim MyFolder
Dim MyMail
Dim MioPath As String

'Definisco la variabile del percorso dove salvare il file
MioPath = "C:UsersXXXXXYYYYYYMiaDir"

' creo la variabile che mi connette ad outlook
Set Outapp = CreateObject("Outlook.application")

'definisco una variabile che contiene tutte le cartelle della sessione di outlook
Set myOlFolders = Outapp.session.Folders

'definisco la cartella in cui voglio lavorare io non ho trovato metodo più dsemplice ma forse esiste...
Set MyFolder = Outapp.session.Folders("aaaaaa.bbbbb@xxxxxx.com").Folders("Inbox").Folders("Prova")

'il Ciclo qui sotto passa in rassegna tutti gli elementi che sono nella cartella che ho selezionato
For Each MyMail In MyFolder.items
' verifico che l'elemento sia una mail
    If TypeName(MyMail) = "MailItem" Then
' estraggo l'oggetto della mail
        Stringa = MyMail.Subject
' ne prendo gli ultimi dieci caratteri (equivalenti alla data gg/mm/dddd)
        Stringa = Right(Stringa, 10)
'Confronto la stringa estratta con la data odierna formattata inmodod da essere coerente
        If Right(Stringa, 10) = Format(Date, "dd/mm/yyyy") Then
'prendo il primo allegato (essendocene uno solo solo per certo che è qulello giusto
            With MyMail.Attachments.Item(1)
'lo salvo in path con il nome che avev nella mail come allegato
                .SaveAsFile MioPath & .DisplayName
            End With
Qui sotto ho lasciato gli else nel caso tu volessi fare delle azioni se l'if non è vero.
        Else
        End If
    Else
    End If
Next
End Sub