Envoi mail avec plusieurs feuilles en pieces jointes.

[anber]

Bonsoir le Forum,
Malgré de nombreuses recherches je n'ai pas trouvé mon bonheur.
Pour l'envoi d'une PJ pas de problème.
Mais pour plusieurs ???
Dans un classeur j'ai X feuilles, en fonction de valeur contenue dans le nom des feuilles je souhaite envoyer ces feuilles par mail, chaque feuille répondant au critère étant envoyée comme un classeur avec pour nom celui de la feuille.
un destinataire peut recevoir plusieurs PJ (classeurs)
Je ne sais pas si j'ai été assez clair
Ci-joint mon ébauche de code
Merci

Sub envoimail()

Dim Outlook As Object
Dim Mail As Object
Dim Objet As String
Dim Corps As String
Dim fichiers, dest As Variant
Dim i As Integer
Dim path As String
Dim fs As Variant
Dim TempFilePath As String
Dim TempFileName As String
Dim FileExtStr As String
Dim FileFormatNum As Long


Application.ScreenUpdating = False

Set fs = CreateObject("Scripting.FileSystemObject")
'Declaration chemin local
TempFilePath = Environ$("temp") & "\"

'Format du fichier en excel 2003
FileExtStr = ".xls": FileFormatNum = -4143

Set Outlook = CreateObject("Outlook.Application")

Objet = "test"
Corps = "Bonjour, " & _
vbCrLf & vbCrLf & _
"BLA BLA" & _
vbCrLf & vbCrLf & _
"BLA BLA" & _
vbCrLf & vbCrLf & _
"Cordialement." & _
vbCrLf & vbCrLf

For n = 1 To Sheets.Count
namesheet = ""
If InStr(Sheets(n).Name, "TDG") Then dest = "toto@yahoo.com"
If InStr(Sheets(n).Name, "TCB") Then dest = "toto1@yahoo.com"
If InStr(Sheets(n).Name, "DFR") Then dest = "toto2@yahoo.com"

namesheet = Sheets(n).Name
namesheet.Copy
Set wb = ActiveWorkbook
wb.SaveAs TempFilePath & namesheet & FileExtStr

Set Mail = Outlook.CreateItem(0)

With Mail
.To = dest
.CC = ""
.BCC = ""
.Subject = Objet
.Body = Corps
.Attachments.Add TempFilePath & namesheet & FileExtStr
.Display
End With

'Fermeture de la feuille ouverte
'ActiveWorkbook.Saved = True
'ActiveWorkbook.Close

'Supression du fichier dans le temp du profil

'strPath = TempFilePath & TempFilePath & namesheet & FileExtStr

'If (fs.FileExists(strPath)) Then
' fs.deletefile (strPath)
'End If

Next n
Application.ScreenUpdating = true
End Sub