XL 2016 Excel - Ouvrir autant de mails Outlook que de Fichiers Excel

Option Explicit
Sub Charge()
Dim Sh  As Worksheet

Set Sh = ActiveSheet
    On Error Resume Next: Sh.Shapes.Range(Array("Rapport")).Delete: On Error GoTo 0
    With Sh.OLEObjects.Add(ClassType:="Forms.Label.1", Left:=20, Top:=20, Width:=200, Height:=100)
        .Name = "Rapport"
        With .Object
            .BorderStyle = 1
            .WordWrap = False
            .AutoSize = True
            .BackColor = &HC0FFFF
            .Caption = "Liste des Fichiers à traiter" & vbLf
        End With
        
     ' La partie vraiment concernée par votre demande : -----------------------
        Dim Dossier     As String
        Dim Fichier     As String
        Dossier = ThisWorkbook.Path & "\"
        Fichier = Dir(Dossier & "*.xlsx")
        Do While Fichier <> ""
            Select Case True
                Case Fichier = ThisWorkbook.Name:   ' Le fichier est le même que celui-ci
                Case Else                           ' le fichier doit etre envoyé
                    .Object = .Object & vbLf & Envoi_Fichier(Fichier)
            End Select
            Fichier = Dir
         Loop
     ' -------------------------------------------------------------------------
        
        .Object = .Object & vbLf
    End With
Set Sh = Nothing

End Sub
Function Envoi_Fichier(Fichier As String) As String
' bla bla .... ma procédure pour outlook
    Envoi_Fichier = "Effectué: " & Fichier
End Function