Outlook - Créer un code VBA pour enregistrer sous avec variable nom fichier

Bonjour,

Je me permets de vous demander de l'aide pour créer un code vba sur Outlook qui va me permettre de récupérer une pièce jointe, l'enregistrer sous mais sous avec une modification du nom de la pièce jointe.

En effet, à mon travail je reçois un fichier quotidien, avec le même nom. J'ai besoin de compiler le contenu de ces fichiers dans un seul fichier à part (je passerai sur powerQuery à ce moment là)
Cependant pour ça, je dois d'avoir extraire l'ensemble des fichiers reçu en PJ sur 2 ans.

Afin d'éviter de tout traiter un par un. je souhaiterais pouvoir extraire automatiquement ces pj et les enregistrer sous un dossier.
J'ai trouvé un code vba qui me permet de faire cette extraction. Cependant étant donnée que le nom du fichier est identique, ca m'écrase le précédent, ce qui fait que je me retrouve avec un seul fichier à la fin...A

Je souhaite ajouter dans le code, la possibilité de renommer les fichier automatiquement en ajoutant par exemple la date de réception du mail.

Voici le code pour extraire et enregistrer sous, pouvez-vous m'aider s'il vous plait si possible de rajouter une fonction avec renomme des fichiers avec comme variable la date de réception du mail.

Public Sub SaveAttachments()
Dim objOL As Outlook.Application
Dim objMsg As Outlook.MailItem
Dim objAttachments As Outlook.Attachments
Dim objSelection As Outlook.Selection
Dim objFileSystem As Object
Dim strFolderpath As String
Dim strFile As String
Dim i As Long
On Error Resume Next
Set objOL = CreateObject("Outlook.Application")
Set objSelection = objOL.ActiveExplorer.Selection
strFolderpath = "C:\Portefeuille client"
Set objFileSystem = CreateObject("Scripting.FileSystemObject")
If Not objFileSystem.FolderExists(strFolderpath) Then
objFileSystem.CreateFolder (strFolderpath)
End If
For Each objMsg In objSelection
Set objAttachments = objMsg.Attachments
If objAttachments.Count > 0 Then
For i = 1 To objAttachments.Count
strFile = objAttachments.Item(i).FileName
objAttachments.Item(i).SaveAsFile strFolderpath & "\" & strFile
Next i
End If
Next
Set objAttachments = Nothing
Set objMsg = Nothing
Set objSelection = Nothing
Set objOL = Nothing
End Sub

Je vous remercie par avance pour votre aide

Bonsoir,

A tester :

Option Explicit

Sub SaveAttachments()

Dim objOL As Outlook.Application
Dim objMsg As Outlook.MailItem
Dim objAttachments As Outlook.Attachments
Dim objSelection As Outlook.Selection
Dim objFileSystem As Scripting.FileSystemObject 'Object
Dim ObjFiles As Scripting.Files 'Object
Dim strFolderpath As String
Dim strFile As String
Dim I As Long

    On Error Resume Next
    Set objOL = CreateObject("Outlook.Application")

    Set objSelection = objOL.ActiveExplorer.Selection
    strFolderpath = "C:\Portefeuille client"
    Set objFileSystem = CreateObject("Scripting.FileSystemObject")

    If Not objFileSystem.FolderExists(strFolderpath) Then
       objFileSystem.CreateFolder (strFolderpath)
    End If

    For Each objMsg In objSelection
        Set objAttachments = objMsg.Attachments
        If objAttachments.Count > 0 Then
           For I = 1 To objAttachments.Count
               strFile = objAttachments.Item(I).FileName
               objAttachments.Item(I).SaveAsFile strFolderpath & "\" & strFile
           Next I
        End If
    Next

    RenommerLeFichier strFolderpath

    Set objAttachments = Nothing: Set objMsg = Nothing: Set objSelection = Nothing
    Set objOL = Nothing:  Set ObjFiles = Nothing

End Sub

Sub RenommerLeFichier(ByVal RepertoireFichiers As String)

Dim Fso As Object, FolderEnCours As Object, FichierEnCours As Object
Dim NomEnCours As String, NouveauNom As String
Dim TabName As Variant

    Set Fso = CreateObject("Scripting.FileSystemObject")
    If Fso.FolderExists(RepertoireFichiers) Then
       Set FolderEnCours = Fso.GetFolder(RepertoireFichiers)
       For Each FichierEnCours In FolderEnCours.Files
           TabName = ""
           NomEnCours = ""
           With FichierEnCours
                If InStr(1, .Name, "En date du", vbTextCompare) = 0 Then
                   TabName = Split(.Name, ".")
                   NomEnCours = .Name
                   NouveauNom = TabName(0) & " En date du " & Format(Date, "YYYY MM DD") & " " & Round(Timer, 0) & "." & TabName(1)
                   Fso.MoveFile FolderEnCours & "\" & NomEnCours, FolderEnCours & "\" & NouveauNom
                End If
          End With
       Next FichierEnCours
    End If
    Set FolderEnCours = Nothing: Set Fso = Nothing

End Sub