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
| Public Sub Mailing()
Dim appOutlook As Outlook.Application
Dim oMail As Outlook.MailItem
Dim EMailSendTo As String, EMailCCTo As String, EMailBCCTo As String
Dim cpt As Integer
Dim nblignes As Long
Dim Rep As VbMsgBoxResult
Dim Lct As Long
Dim NbLctr As Double
Dim Lctr As Range
Dim I As Integer
On Error GoTo traiteErreur
'Demande de confirmation de lancement du mailing
Rep = MsgBox(" Confirmation du début de mailing? " & stFile, vbQuestion + vbOKCancel, "Mailing via Outlook")
If Rep = 2 Then Exit Sub
cpt = 0
'Compte le nbre de lignes pour le nbre d'enregistrements
ActiveWorkbook.Sheets("Echeances_contrats").Select
Range("L2").Select
nblignes = Range("L2").CurrentRegion.Rows.Count - 1
Do While cpt < nblignes
Range("S2").Select 'Reste pb de positionnement sur la 1ere ligne de chaque contrat
MsgBox ("cpt = " & cpt)
'Test pour n'envoyer qu'un seul mail par contrat a plusieurs lignes
If ActiveCell.Offset(cpt, -7).Value <> ActiveCell.Offset(cpt - 1, -7).Value Then
EMailSendTo = ActiveCell.Offset(cpt, 0).Value
EMailCCTo = ActiveCell.Offset(cpt, 2).Value
Set appOutlook = CreateObject("outlook.application")
Set oMail = appOutlook.CreateItem(olMailItem)
With oMail
.To = EMailSendTo
.CC = EMailCCTo
.Subject = "AVIS DE FIN DE CONTRAT"
.BodyFormat = olFormatHTML
.HTMLBody = "<HTML><body><u>A l'attention du Responsable Informatique</u><hr /><BR>Cher(e) client(e) ,<BR><BR>Suivant nos informations et sauf erreur, votre Contrat de maintenance numéro : </body>" & ActiveCell.Offset(cpt, -7).Value _
& "<body><i><BR>(ce numéro figure dans la zone NOTRE REFERENCE de votre facture)</i></body>" _
& "<body><BR>arrive à échéance le: </body>" & ActiveCell.Offset(cpt, -8).Value _
& "<body><BR>Référence Commande: </body>" & ActiveCell.Offset(cpt, -4).Value _
& "<body><BR>Commentaires sur ce contrat: </body>" & ActiveCell.Offset(cpt, 4).Value _
& "<body><BR>Nous souhaitons connaître vos intentions quant au renouvellement de celui-ci</body>" _
& "<body><BR>Cet avis est automatisé, si des négociations sont en-cours avec notre service commercial, merci de ne pas en tenir compte. </body>" _
& "<body><BR><BR>Dans l'attente, nous demeurons à votre disposition et vous prions d'agréer, Madame,Monsieur, l'expression de nos salutations distinguées.</body>" _
& "<body><BR><BR><u>Votre contact :</u></body>" & " " & ActiveCell.Offset(cpt, 1).Value & "<body> - Courriel : </body>" & ActiveCell.Offset(cpt, 2).Value & "<body> - Tel : </body></HTML>" & ActiveCell.Offset(cpt, 3).Value
' Reste à trouver le moyen de lister les item par contrat dans le message
'Test du nbre de ligne du contrat
Range("X" & cpt + 2).Select
ActiveCell.Formula = "=COUNTIF(Lctr,RC[-12])"
NbLctr = ActiveCell.Value
MsgBox ("Nbre de lignes du contrat = " & NbLctr)
'Affichage de chaque item du contrat - Reste à trouver le moyen de l'intégrer dans le corps du message
For I = 0 To NbLctr Step 1
MsgBox ("Item n° :" & I & " " & ActiveCell.Offset(I, -8).Value)
Next
.Send
End With
Set oMail = Nothing
Set appOutlook = Nothing
End If
cpt = cpt + 1
Loop
' message de fin de mailing
MsgBox cpt & " Messages envoyés via Outlook - Visibles dans le Répertoire Eléments envoyés", vbInformation, "Mailing via Outlook"
traiteErreur:
Select Case Err.Number
Case -2147467259
MsgBox ActiveCell.Offset(cpt, -5).Value & " >>> Erreur de saisie dans une adresse mail ", vbCritical, "Mailing Outlook"
Case Else
MsgBox Err.Description
End Select
' poursuite exécution de la procédure
'Resume Next
End Sub |
Insérer textes et cellules excel dans un message en HTML
Répondre avec citation
Partager