Discussion :

[Sebastien_F]

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 :

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
 
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]

[Tête de chat]

Bnjour

essaye d'ajouter un

Code :

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

myvalue = ""

avant la boucle "for i = 1 to 5"

[Sebastien_F]

Bnjour

essaye d'ajouter un

Code :

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

myvalue = ""

avant la boucle "for i = 1 to 5"

Bonjour Tête de chat,

Cela ne semble pas fonctionner

La macro se lance mais les mails ne s'affichent même plus

[Tête de chat]

Tu as fait ça ?

Code :

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

1
2
3
4
5
 
myvalue =""
For i = 5 To btm
        myvalue = myvalue & "<br>" & ws.Cells(i, 2).Value
 Next i

[Sebastien_F]

Mea Culpa !!! Le soucis était entre la chaise et le clavier

Ayant 2 macro quasi similaire, j'avais modifié un module mais j'activais la macro de l'autre module

un grand merci !!!

Pour ceux que ça intéresse la macro ci dessous permets donc d’écrire un mail standard en fonction du contenu d'un nombre variable de cellules ( d'un onglet ), de l'envoyer a une liste de destinataires et d'y joindre des .pdf individuels

( Ce n'est pas de moi mais c'est le résultat d'ajout de blocs trouvés sur différents forum )

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
 
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
        myvalue = ""
        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

[Sebastien_F]

En revanche... indépendamment de notre précédent sujet :

_ je constate qu'il y a un saut de ligne en tout début des mails qui sont édités ( entre le début du message et le bonjour...)
Est il possible de l'enlever ? ( voir image ci-dessous )

_ Comment faire pour imposer un Calibri 11 en police de mail

Se faisant, ce sera la cerise sur la cerise du gâteau