Envoi mail automatoque

Bonjour,

J'ai créé une macro permettant d'enoyer un mail en auto avec pj à une liste de personne.

Ci-dessous le code.

Tout fonctionne bien sauf que le 1er mail a 1 PJ, le 2ème mail deux pJ, le 3 3 PJ etc etc

Comme je dois envoyé plus d'uen cetaine de mail si je lance le dernier aura 100 PJ....

Quelqu'un a une idée ?

Merci d'avance

Sub ENVOI_MAIL()
'
' ENVOI_MAIL Macro
'

EXP_MAIL = "toto@total.com"
'
Sheets("LISTE").Select
'
nbr_ligne = 2
'
While Cells(nbr_ligne, 1) <> ""
'
'test adresse mail
If Cells(nbr_ligne, 4) <> "Ok" Or Cells(nbr_ligne, 5) <> "Ok" Then GoTo 10
'
DEST_MAIL = Cells(nbr_ligne, 3).Value
'
Sheets("MAIL").Select
'
ActiveSheet.Range(Cells(1, 1), Cells(28, 1)).Select ' Corps du mail
ActiveWorkbook.EnvelopeVisible = True
'
With ActiveSheet.MailEnvelope
   .Item.SentOnBehalfOfName = "rm.adv-facturation@total.com"
   .Item.To = DEST_MAIL
   .Item.Subject = " test Tentative frauduleuse de modification de coordonnées bancaires pour les paiements à des entités du groupe TOTAL"
   .Item.Attachments.Add ("O:\CM-PROC\Mailing\Mail\20160225154208.pdf")
   .Item.Send
End With
'
10
nbr_ligne = nbr_ligne + 1
'
Sheets("LISTE").Select
'
Wend
'
ActiveWorkbook.EnvelopeVisible = False
'
Sheets("DEBUT").Select
MsgBox "Envoi terminé !"
'

End Sub

Bonjour,

essaie ainsi

Sub ENVOI_MAIL()
'
' ENVOI_MAIL Macro
'

EXP_MAIL = "toto@total.com"
'
Sheets("LISTE").Select
'
nbr_ligne = 2
'
While Cells(nbr_ligne, 1) <> ""
'
'test adresse mail
If Cells(nbr_ligne, 4) <> "Ok" Or Cells(nbr_ligne, 5) <> "Ok" Then GoTo 10
'
DEST_MAIL = Cells(nbr_ligne, 3).Value
'
Sheets("MAIL").Select
'
ActiveSheet.Range(Cells(1, 1), Cells(28, 1)).Select ' Corps du mail
ActiveWorkbook.EnvelopeVisible = True
'
With ActiveSheet.MailEnvelope
 Do Until .Item.attachments.Count = 0
          .Item.attachments(1).Delete
      Loop

   .Item.SentOnBehalfOfName = "rm.adv-facturation@total.com"
   .Item.To = DEST_MAIL
   .Item.Subject = " test Tentative frauduleuse de modification de coordonnées bancaires pour les paiements à des entités du groupe TOTAL"
   .Item.Attachments.Add ("O:\CM-PROC\Mailing\Mail\20160225154208.pdf")
   .Item.Send
End With
'
10
nbr_ligne = nbr_ligne + 1
'
Sheets("LISTE").Select
'
Wend
'
ActiveWorkbook.EnvelopeVisible = False
'
Sheets("DEBUT").Select
MsgBox "Envoi terminé !"
'

End Sub

désolé mais ça plante à Do until ......

Hello bis

J'ai écris ça et ça fonctionne merci de ton aide !!!!!!

With ActiveSheet.MailEnvelope
Do Until .Item.Attachments.Count = 0
          .Item.Attachments(1).Delete
      Loop

End With
With ActiveSheet.MailEnvelope
   .Item.SentOnBehalfOfName = "rm.adv-facturation@total.com"
   .Item.To = DEST_MAIL
   .Item.Subject = " test Tentative frauduleuse de modification de coordonnées bancaires pour les paiements à des entités du groupe TOTAL"
   .Item.Attachments.Add ("O:\CM-PROC\Mailing\Mail\20160225154208.pdf")
   .Item.Send
'   .Item.Attachments.Delete
End With