Bonjour,

J'ai réalisé une macro pour envoyer des emails à partir d'excel.
Ces derniers sont expédiés, un à un, a toutes les personnes possédant une adresse email. (je l'ai testée, elle fonctionne)

Mon problème vient du code pour insérer les pièces jointes, je souhaiterais envoyer plusieurs pièces jointes, les mêmes, à tous. Avec mon code je ne peux envoyer qu’une pièce jointe.

Pourriez-vous m’aider à finaliser cette macro ?

Code : Sélectionner tout - Visualiser dans une fenêtre à part
1
2
3
1ère PJ : colonne U, ligne 7
2ème PJ : colonne U, ligne 8
3ème PJ : colonne U, ligne 9
Merci pour votre aide

Code vb : 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
Sub Email()
' Filtre la colonne des adresses mails
Columns("O:O").Select
Selection.AutoFilter
Selection.AutoFilter Field:=1, Criteria1:="<>"
' Déclaration des variables
Dim outlookDossier As Outlook.MAPIFolder
Dim outlookMessage As Outlook.MailItem
Dim vAdresse As String
Dim vObjet As String
Dim vMessage As String
Dim PJ As String
Dim vCellule As Object
' Récupération du message
    For Each vCellule In Range("U11:U26")
        vMessage = vMessage & vCellule & Chr(10)
    Next
 
' Ajout pièce jointe
If PJ <> "" Then
    If Dir(PJ, vbNormal Or vbReadOnly Or vbHidden Or vbSystem Or vbArchive) = "" Then
        MsgBox "fichier introuvable !", vbCritical, "Attention"
        Set outlookDossier = Nothing
        Set outlookMessage = Nothing
        Exit Sub
    End If
End If
 
' Envoi les messages à tout le groupe
Range("O2").Select
Do While ActiveCell <> ""
    vAdresse = ActiveCell
    vObjet = Range("U5")
    PJ = Range("U7")
    Set outlookDossier = GetObject("", "Outlook.Application").GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)
    Set outlookMessage = outlookDossier.Items.Add
    With outlookMessage
        .Subject = vObjet
        .Recipients.Add vAdresse
        .Body = vMessage
        .OriginatorDeliveryReportRequested = True
        .ReadReceiptRequested = True
        .Attachments.Add PJ
        .Send
    End With
    ActiveCell.Offset(0, 1) = "x"
    ActiveCell.Offset(1, 0).Select
    Loop
    Set outlookMessage = Nothing
    Set outlookDossier = Nothing
' Supprime le filtrage de la colonne des émails
Selection.AutoFilter
ActiveWorkbook.Save
End Sub