1 pièce(s) jointe(s)
Création d'un mail constitué d'un nombre variable de cellules
Bonjour à Tous !!
Je tente de réaliser une macro qui, à partir d'une base de données Excel, me permettrait d'envoyer un fichier .PDF personnalisé à chaque destinataire mais avec un corps de mail identique et qui serait le contenu de cellules ( pour ne pas avoir a le mettre dans le code et le changer facilement).
Grace à quelques blocs VBA trouvés sur différents forums j'ai réussi à éditer une macro qui semble fonctionner dans l'ensemble ( merci à tous car developpez.net m'aide beaucoup !! ) mais je n'arrive pas à mes fins en ce qui concerne le corps du mail...
En bref, la macro rédige des mails à mes destinataires ( A, B, C );
La macro affecte à chaque destinataire/mail un ficher .PDF ( A.pdf, B.pdf, C.pdf ) qui est rangé dans un dossier que l'utilisateur peut trouver via une MsgBox
Le corps du mail se trouve dans l'onglet "Courrier" et la macro le trouve bien mais lorsque je la lance le destinataire A à le corps de mail correct, le destinataire B à 2 fois le corps de mail :?, le destinataire C à 3 fois le corps de mail :( , Etc ...
J'arrive à la limite de mes compétence et je me permets de solliciter votre aide sur le sujet; il y a peut être d'autres erreurs dans le code mais pourriez vous s'il vous plait m'aider ???
Code:
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
|
Sub Lancement_Diffusion()
Dim ret As Integer
ret = MsgBox("Cette option lance la diffusion des courriers" & vbNewLine & "Etes vous certain de vouloir poursuivre", _
vbYesNo + vbExclamation + vbDefaultButton3, "Demande de confirmation")
If ret = vbNo Then
Exit Sub
Else
Application.ScreenUpdating = False
Sheets("Liste épurée").Activate
Dim dossier As Object, chemin$
Set dossier = Application.FileDialog(msoFileDialogFolderPicker)
If dossier.Show = -1 Then
chemin = dossier.SelectedItems(1)
'MsgBox chemin
Else: Exit Sub
End If
Dim OutApp As Object
Dim OutMail As Object
Dim signature As String
Dim Destinataire As String
Dim cell As Range
Set OutApp = CreateObject("Outlook.Application")
On Error GoTo cleanup
For Each cell In ThisWorkbook.Worksheets("Liste épurée").Columns("D").Cells.SpecialCells(xlCellTypeConstants)
If cell.Value Like "?*@?*.?*" Then
Set OutMail = OutApp.CreateItem(0)
With OutMail
.Display
End With
signature = OutMail.htmlbody
On Error Resume Next
Dim ws As Worksheet
Set ws = Worksheets("Courrier")
btm = ws.Cells(Rows.Count, 2).End(xlUp).Row
For i = 5 To btm
myvalue = myvalue & "<br>" & ws.Cells(i, 2).Value
Next i
With OutMail
.To = cell.Value
.Subject = ws.Range("B3").Value
.htmlbody = myvalue & _
signature
.Attachments.Add (chemin & "\" & Cells(cell.Row, "A").Value & ".pdf")
.Display 'mettre .Send pour envoyer ou .Display pour simplement créer des mails
End With
On Error GoTo 0
Set OutMail = Nothing
End If
Next cell
cleanup:
Set OutApp = Nothing
Application.ScreenUpdating = True
Sheets("Courrier").Activate
End If
MsgBox "Courrier(s) envoyé(s)", vbInformation
End Sub[ATTACH]632402[/ATTACH] |
