Bonjour,
J'ai crée un fichier il y a quelques mois qui fonctionnait mais aujourd'hui j'ai ce problème.
A force de modifier je me suis perdu et il bug en envoyant des mails toutes les secondes !! (une boite s'ouvre et demande d'accepter - je ne peux pas la retirer protection entreprise)
voici mon code :
J'ai crée un fichier il y a quelques mois qui fonctionnait mais aujourd'hui j'ai ce problème.
A force de modifier je me suis perdu et il bug en envoyant des mails toutes les secondes !! (une boite s'ouvre et demande d'accepter - je ne peux pas la retirer protection entreprise)
voici mon code :
VB:
Dim messagerie As Object
Dim email As Object
Dim cel As Range
Set messagerie = CreateObject("Outlook.Application")
For Each cel In Range("e9:e" & Range("e9").End(xlDown).Row)
Set email = messagerie.CreateItem(0)
With email
On Error Resume Next
Set oOutlook = GetObject(, "Outlook.Application")
On Error GoTo 0
If oOutlook Is Nothing Then
Shell "Outlook.exe", vbHide
End If
'Liste des destinataires
.To = Sheets("Adresses Mail Destinataires").Range("e9").Value
'Sujet :
.Subject = Sheets("Menu").Range("a113").Value
'Corps du mail :
.Body = "Bonjour," & vbCrLf _
& vbCrLf _
& "Vous trouverez ci joint la " & Sheets("Menu").Range("a113").Value & vbCrLf _
& vbCrLf _
& "Cordialement" & vbCrLf _
& vbCrLf & vbCrLf _
& "XXX XXXX"
.Send
End With
Set email = Nothing
Next cel
Set messagerie = Nothing
With ActiveWorkbook
.Close SaveChanges:=False
End With