Envoi de mailing avec cc et cci

**stephadm** · 26/10/2012, 15h45

Bonjour au forum,

Voilà , je travaille sur un projet de mailing mais je rencontre différentes erreurs.

Pour commencer, les mails ne partent pas !

Pourquoi, ai-je oublié quelque chose ?

Merci

Stephanie

**Oliv-** · 26/10/2012, 16h40

Bonjour,
Sympathique projet, qui est à l'origine de ce code ?
Chez moi cela part bien j'ai bien sûr changé le serveur smtp. par contre c'est ta gestion d'erreur qui te fait croire que ca ne marche pas.
Attention aussi à un éventuel proxy.

edit :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
Private Sub Btn_Newsletter_Click()
Dim strHTML As String
 
Me.Message = "Envoi en cours patientez..."
If MsgBox("Confirmer l'envoi du mail", vbYesNo) = vbNo Then
   Me.Message = "Envoi abandonné"
   Exit Sub
End If
' sauvegarde le texte du mail et l'objet
'--------------
' Objet
'-------------
Feuil11.Range("Param_obj_mail") = Me.Objet
'----------------------------------------------
' texte du mail dans N cellules
'----------------------------------------------
'Raz du texte précédent
Lig = Feuil11.Range("Param_text_mail").Row
col = Feuil11.Range("Param_text_mail").Column
Do Until Feuil11.Cells(Lig, col) = ""
    Feuil11.Cells(Lig, col) = ""
    Lig = Lig + 1
Loop
' nombre de cellules à valoriser
NbCell = Len(Me.TexteMail) / 255
Lig = Feuil11.Range("Param_text_mail").Row
col = Feuil11.Range("Param_text_mail").Column
For i = 0 To NbCell
   Feuil11.Cells(Lig + i, col) = Mid(Me.TexteMail, 1 + (i * 255), 255)
Next i
'---------------------------------
' piece jointe
'-----------------------
Feuil11.Range("Param_piece_jointe") = Me.Piece_jointe
'Sheets("Feuil11").Range("Param_serv_SMTP") = Me.Serveur_smtp
 
If Me.Liste_Dest.ListCount = 0 Then Exit Sub
Destinataires = ""
For i = 0 To Me.Liste_Dest.ListCount - 1
     Destinataires = Destinataires & Me.Liste_Dest.List(i, 1) & ";"
Next i
'==================================================
' Constitution du mail
'==================================================
'  LeMail = Me.TexteMail
  strHTML = ""
strHTML = strHTML & "<HEAD>"
strHTML = strHTML & "<BODY background='http://www.test.fr/images/fonds/fond-1.png' left top fixed no-repeat<BR>"
strHTML = strHTML & "Bonjour & NomCli,<BR>"
strHTML = strHTML & " <BR>"
strHTML = Me.TexteMail
strHTML = strHTML & " <BR>"
strHTML = strHTML & "Vous souhaitant bonne reception, nous restons a votre disposition pour tous renseignements.<BR>"
strHTML = strHTML & " <BR>"
strHTML = strHTML & "<i>La lecture du fichier joint necessite la presence sur votre ordinateur du logiciel Adobe Acrobat Reader.</i><BR>"
strHTML = strHTML & "<i>Si vous ne possedez pas ce logiciel cliquez sur : <A href='http://www.adobe.fr/products/acrobat/readstep.html'>www.adobe.fr/products/acrobat/readstep.html</A> pour le telecharger.</i><BR>"
strHTML = strHTML & " <BR>"
strHTML = strHTML & "Sinceres salutations.<BR>"
strHTML = strHTML & "F. COCHIN<BR>"
strHTML = strHTML & "<img src='http://www.test.fr/images/Encart_email.png'><BR>"
strHTML = strHTML & "<center><img src='http://www.test.fr/images/icones/Draftsadres.gif'>TesT<BR>"
strHTML = strHTML & "<center><img src='http://www.test.fr/images/icones/Draftstel.gif'>04.54.61.89.54<BR>"
strHTML = strHTML & "<center><img src='http://www.test.fr/images/icones/Draftsport.gif'></A>06.07.13.32.62<BR>"
strHTML = strHTML & "<center><img src='http://www.test.fr/images/icones/Draftsemail.gif'><A href='http://www.test.fr/'><i>www.test.fr</i></A></center><BR>"
strHTML = strHTML & "</BODY>"
strHTML = strHTML & ""
'========================
'  Envoi avec CDO Message
'========================
    Dim iMsg As Object
    Dim iConf As Object
    '    Dim Flds As Variant
 
    Set iMsg = CreateObject("CDO.Message")
    Set iConf = CreateObject("CDO.Configuration")
 
 
        iConf.Load -1    ' CDO Source Defaults
        Set Flds = iConf.Fields
        With Flds
            .Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
            .Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") _
                           = Me.Serveur_smtp
                          ' = "Fill in your SMTP server here"
            .Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
            .Update
        End With
 
Dim tab_env() As String
ReDim tab_env(Me.Liste_Dest.ListCount + 1)
 
NbError = 0
For i = 0 To Me.Liste_Dest.ListCount - 1
 On Error GoTo 0 'Resume Next
 Err.Clear
    With iMsg
        Set .Configuration = iConf
        .To = Me.Liste_Dest.List(i, 1)
        If i = 0 Then
            If Not IsNull(Me.Liste_Dest_copie.List(i, 1)) Then
           .CC = Me.Liste_Dest_copie.List(i, 1)
           End If
           If Not IsNull(Me.Liste_Dest_copie_cachee.List(i, 1)) Then
 
           .BCC = Me.Liste_Dest_copie_cachee.List(i, 1)
           End If
        End If
        .From = Me.From
        .Subject = Me.Objet
        .HTMLBody = strHTML
'        .TextBody = LeMail
        If Me.Piece_jointe <> "" Then
          .AddAttachment Me.Piece_jointe
        End If
        Cetenvoi = .send
       ' .send
    End With
    If Err.Number <> 0 Then
        tab_env(i) = "KO"
        NbError = NbError + 1
    Else
        tab_env(i) = "OK"
    End If
Next i
If NbError > 0 Then
   LeMsgError = NbError & " mail(s) ne sont pas partis : " & Chr(10)
   For i = 0 To Me.Liste_Dest.ListCount - 1
      If tab_env(i) = "KO" Then
         LeMsgError = LeMsgError & Me.Liste_Dest.List(i, 1) & Chr(10)
      End If
   Next i
   Me.Message = LeMsgError
Else
   'MsgBox "les mails ont bien été envoyés"
   UserForm5.Show
End If
End Sub

**stephadm** · 26/10/2012, 20h59

Bonsoir Oliv- et au forum,

Je me suis inspirée d'une partie du code sinon le reste vient de moi. Je me souviens plus d’où j'avais trouvé celui-ci.

Avec du recul et ce que j'ai sur ce forum, j’aurais du mettre la source dans mon fichier. Désolé de ne pas pouvoir en dire plus.

j'ai refais des tests mais j'ai un problème ici

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

Cetenvoi = .send

souligné en jaune avec message erreur d'execution '-2147220978 (804020e)': le serveur a rejeté l'adresse de l'expéditeur...

Question :
Peut-on amélioré de façon à éviter les boutons <<-Tous, <-Retirer et Tous->> multiplié par 3 ?

Merci

Stephanie

**Oliv-** · 27/10/2012, 21h16

c'est l'adresse cci je pense qui correspond à un nom de site web pas email.

Tu dois remettre ton on error resume next juste avant cette ligne
et renvoyer la description de l'erreur dans ton log.

**patricktoulon** · 28/10/2012, 02h09

bonsoir
le code viens de toi????

regarde dans ma signature tu en a un tout fait avec CDO
tu dois etre telepathe

il ne te reste plus qu'a ajouter ta liste de destinataire

au plaisir

**Oliv-** · 28/10/2012, 14h54

Salut Patrick,
C'est marrant j'étais hier soir justement en train d'essayer de lire ton fichier mailer..., interrompu par un pb de disque dur...
Bon il y a de la correction orthographique à faire !! Mise à part cela, tu ne gères pas non plus les erreurs sur .send
J'aime bien la version de Stéphanie, qui est plus de l'envoi de masse alors que le tien est unitaire.

Envoi de mailing avec cc et cci

Macros et VBA Excel

Vue hybride

Discussions similaires

Partager

Partager