Importer et renommer les pièces jointes outllook

Bonsoir

Besoin d'aide, je cherche un programme en VBA qui récupère les pièces jointes excel dans des email Outlook (boite de réception ou dossier archivé) ensuite les renommé selon les expéditeur et l'enregistre automatiquement dans un dossier spécifique. j’espère qu'il ya un magicien parmi vous qui peu réalisé ce tour

j'ai trouvé le programme ci-dessous qui enregistre les Pièce-joints dans un dossier, je dois maintenant intégrer un code afin qu'il renomme les pièces joints selon l’expéditeur ;

Sub SaveAttachment()

'Declaration

Dim myItems, myItem, myAttachments, myAttachment As Object

Dim myOrt As String

Dim myOlApp As New Outlook.Application

Dim myOlExp As Outlook.Explorer

Dim myOlSel As Outlook.Selection

Dim i As Integer

'Boîte de dialogue simple pour le chemin de sauvegarde

myOrt = InputBox("Destination", "Save Attachments", "C:\CdeDELL\Facture\")

On Error Resume Next

'Actions sur les objets sélectionnés

Set myOlExp = myOlApp.ActiveExplorer

Set myOlSel = myOlExp.Selection

'boucle

For Each myItem In myOlSel

Set myAttachments = myItem.Attachments

If myAttachments.Count > 0 Then

'Ajoute une remarque dans le corps du message

myItem.Body = myItem.Body & vbCrLf & _

"pièce jointe enlevée:" & vbCrLf

'for all attachments do...

For i = 1 To myAttachments.Count

'save them to destination

myAttachments(i).SaveAsFile myOrt & _

myAttachments(i).DisplayName

myItem.Body = myItem.Body & _

"File: " & myOrt & _

myAttachments(i).DisplayName & vbCrLf

Next i

'Enlève les pièces jointes du message

While myAttachments.Count > 0

myAttachments(1).Delete

Wend

'Sauvegarde le message sans ses pièces jointes

myItem.Save

End If

Next

Set myItems = Nothing

Set myItem = Nothing

Set myAttachments = Nothing

Set myAttachment = Nothing

Set myOlApp = Nothing

Set myOlExp = Nothing

Set myOlSel = Nothing

End Sub

merci d'avance