Bonjour,
J'essaye d'envoyer automatiquement un mail à une liste: pas de problème avec
le code ci-dessous (adapté d'un userform de cd-mail, merci à son créateur);
je fais en sorte que le mail soit envoyé individuellement à chaque
destinataire.
Il faudrait maintenant que les fichiers attachés soient tous attachés dans
chaque envoi, qu'il y en ait 0 ou plusieurs. Ils sont dans Listbox1, et je
pensais que la boucle For J to... pourrait le faire, mais nenni, les
messages partent sans fichier attaché...
Voici le code:
Private Sub CommandButton3_Click()
Dim iMsg As Object
Dim iConf As Object
Dim top As String
Dim i As Integer
Dim j As Integer
For i = 1 To (ListBox2.ListCount)
top = (ListBox2.List(i - 1, 0))
Application.ScreenUpdating = False
Set iMsg = CreateObject("CDO.Message")
Set iConf = CreateObject("CDO.Configuration")
With iMsg
Set .Configuration = iConf
.To = top
.CC = ""
.BCC = ""
.From = TextBox1.Value
.Subject = TextBox4.Value
.TextBody = TextBox3.Value
For j = 1 To (ListBox1.ListCount)
.AddAttachment (ListBox1.List(j - 1, 0))
Next j
.Send
End With
Next
Set iMsg = Nothing
Set iConf = Nothing
Application.ScreenUpdating = True
End Sub
Cette action est irreversible, confirmez la suppression du commentaire ?
Signaler le commentaire
Veuillez sélectionner un problème
Nudité
Violence
Harcèlement
Fraude
Vente illégale
Discours haineux
Terrorisme
Autre
JB
Bonjour,
http://cjoint.com/?dmqGQb0Xm8
Programme équivalent:
ChDir ActiveWorkbook.Path répertoireAppli = ActiveWorkbook.Path ' Penser à Outils/Références Outlook '--- Envoi par mail Dim olapp As Outlook.Application Sheets("destinataires").Select [A11].Select Do While Not IsEmpty(ActiveCell) Dim msg As MailItem Set olapp = New Outlook.Application Set msg = olapp.CreateItem(olMailItem) msg.To = ActiveCell.Value msg.Subject = [A2] msg.Body = [A5] & Chr(13) & Chr(13) & [A8].Value & Chr(13) & Chr(13) For j = 0 To ActiveSheet.ListBox1.ListCount - 1 msg.Attachments.Add Source:=répertoireAppli & "" & ActiveSheet.ListBox1.List(j) Next j msg.Send ActiveCell.Offset(1, 0).Select Loop
Cordialement JB
Bonjour,
http://cjoint.com/?dmqGQb0Xm8
Programme équivalent:
ChDir ActiveWorkbook.Path
répertoireAppli = ActiveWorkbook.Path ' Penser à
Outils/Références Outlook
'--- Envoi par mail
Dim olapp As Outlook.Application
Sheets("destinataires").Select
[A11].Select
Do While Not IsEmpty(ActiveCell)
Dim msg As MailItem
Set olapp = New Outlook.Application
Set msg = olapp.CreateItem(olMailItem)
msg.To = ActiveCell.Value
msg.Subject = [A2]
msg.Body = [A5] & Chr(13) & Chr(13) & [A8].Value & Chr(13) &
Chr(13)
For j = 0 To ActiveSheet.ListBox1.ListCount - 1
msg.Attachments.Add Source:=répertoireAppli & "" &
ActiveSheet.ListBox1.List(j)
Next j
msg.Send
ActiveCell.Offset(1, 0).Select
Loop
ChDir ActiveWorkbook.Path répertoireAppli = ActiveWorkbook.Path ' Penser à Outils/Références Outlook '--- Envoi par mail Dim olapp As Outlook.Application Sheets("destinataires").Select [A11].Select Do While Not IsEmpty(ActiveCell) Dim msg As MailItem Set olapp = New Outlook.Application Set msg = olapp.CreateItem(olMailItem) msg.To = ActiveCell.Value msg.Subject = [A2] msg.Body = [A5] & Chr(13) & Chr(13) & [A8].Value & Chr(13) & Chr(13) For j = 0 To ActiveSheet.ListBox1.ListCount - 1 msg.Attachments.Add Source:=répertoireAppli & "" & ActiveSheet.ListBox1.List(j) Next j msg.Send ActiveCell.Offset(1, 0).Select Loop
Cordialement JB
André Riberi
Merci de ta réponse, mais je n'ai pas outlook, je préfèrerais une solution qui ne l'appelle pas directement
"JB" a écrit dans le message de news:
Bonjour,
http://cjoint.com/?dmqGQb0Xm8
Programme équivalent:
ChDir ActiveWorkbook.Path répertoireAppli = ActiveWorkbook.Path ' Penser à Outils/Références Outlook '--- Envoi par mail Dim olapp As Outlook.Application Sheets("destinataires").Select [A11].Select Do While Not IsEmpty(ActiveCell) Dim msg As MailItem Set olapp = New Outlook.Application Set msg = olapp.CreateItem(olMailItem) msg.To = ActiveCell.Value msg.Subject = [A2] msg.Body = [A5] & Chr(13) & Chr(13) & [A8].Value & Chr(13) & Chr(13) For j = 0 To ActiveSheet.ListBox1.ListCount - 1 msg.Attachments.Add Source:=répertoireAppli & "" & ActiveSheet.ListBox1.List(j) Next j msg.Send ActiveCell.Offset(1, 0).Select Loop
Cordialement JB
Merci de ta réponse, mais je n'ai pas outlook, je préfèrerais une solution
qui ne l'appelle pas directement
"JB" <boisgontier@hotmail.com> a écrit dans le message de news:
1142177711.227156.186240@j33g2000cwa.googlegroups.com...
Bonjour,
http://cjoint.com/?dmqGQb0Xm8
Programme équivalent:
ChDir ActiveWorkbook.Path
répertoireAppli = ActiveWorkbook.Path ' Penser à
Outils/Références Outlook
'--- Envoi par mail
Dim olapp As Outlook.Application
Sheets("destinataires").Select
[A11].Select
Do While Not IsEmpty(ActiveCell)
Dim msg As MailItem
Set olapp = New Outlook.Application
Set msg = olapp.CreateItem(olMailItem)
msg.To = ActiveCell.Value
msg.Subject = [A2]
msg.Body = [A5] & Chr(13) & Chr(13) & [A8].Value & Chr(13) &
Chr(13)
For j = 0 To ActiveSheet.ListBox1.ListCount - 1
msg.Attachments.Add Source:=répertoireAppli & "" &
ActiveSheet.ListBox1.List(j)
Next j
msg.Send
ActiveCell.Offset(1, 0).Select
Loop
Merci de ta réponse, mais je n'ai pas outlook, je préfèrerais une solution qui ne l'appelle pas directement
"JB" a écrit dans le message de news:
Bonjour,
http://cjoint.com/?dmqGQb0Xm8
Programme équivalent:
ChDir ActiveWorkbook.Path répertoireAppli = ActiveWorkbook.Path ' Penser à Outils/Références Outlook '--- Envoi par mail Dim olapp As Outlook.Application Sheets("destinataires").Select [A11].Select Do While Not IsEmpty(ActiveCell) Dim msg As MailItem Set olapp = New Outlook.Application Set msg = olapp.CreateItem(olMailItem) msg.To = ActiveCell.Value msg.Subject = [A2] msg.Body = [A5] & Chr(13) & Chr(13) & [A8].Value & Chr(13) & Chr(13) For j = 0 To ActiveSheet.ListBox1.ListCount - 1 msg.Attachments.Add Source:=répertoireAppli & "" & ActiveSheet.ListBox1.List(j) Next j msg.Send ActiveCell.Offset(1, 0).Select Loop
