Discussion :

[nanie13]

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

[SilkyRoad]

bonsoir

Tu peux gérer l'envoi de plusiseurs pièces jointes de la manière suivante:

Code :

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

1
2
3
4
5
6
7
8
9
10
11
    With outlookMessage
        .Subject = vObjet
        .Recipients.Add vAdresse
        .Body = vMessage
        .OriginatorDeliveryReportRequested = True
        .ReadReceiptRequested = True
        .Attachments.Add PJ_1
        .Attachments.Add PJ_2
        .Attachments.Add PJ_3
        .Send
    End With

bonne soirée
michel

[nanie13]

Bonjour et merci
Ma macro fonctionne parfaitement

[nanie13]

Re bonjour,

C'est à devenir folle, ma macro n'a fonctionnée qu'une fois, maintenant elle bloque à :

Code :

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

.Attachments.Add PJ_1

Quelqu'un pourrait t il corriger s'il vous plait ?

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
Sub Envoi_Email_à_partir_excel()
 
' 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 vCellule As Object
Dim PJ_1 As String
Dim PJ_2 As String
Dim PJ_3 As String
 
' Récupération du message
    For Each vCellule In Range("U11:U26")
        vMessage = vMessage & vCellule & Chr(13)
    Next
 
' Envoi les messages à tout le groupe
Range("O2").Select
Do While ActiveCell <> ""
    vAdresse = ActiveCell
    vObjet = Range("U5")
    PJ_1 = Range("U7")
    PJ_2 = Range("U8")
    PJ_3 = Range("U9")
    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_1
        .Attachments.Add PJ_2
        .Attachments.Add PJ_3
        .Subject = vObjet
        .Recipients.Add vAdresse
        .Body = vMessage
        .OriginatorDeliveryReportRequested = True
        .ReadReceiptRequested = True
        .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

[philben]

bonjour,

Une raison possible du plantage :

l'ajout de pièce jointe fonctionne si la source est renseignée et si le fichier existe réellement.

Pour vérifier ceci, il faut ajouter la fonction suivante dérivée de la FAC (silkyroad) :

Code :

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

1
2
3
4
 
Function FichierExiste(NomFichier As String) As Boolean
    If NomFichier <> "" Then FichierExiste = Dir(NomFichier) <> vbNullString
End Function

puis modifier les lignes suivantes de votre code par :

Code :

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

1
2
3
4
 
If FichierExiste(PJ_1) Then .Attachments.Add PJ_1
If FichierExiste(PJ_2) Then .Attachments.Add PJ_2
If FichierExiste(PJ_3) Then .Attachments.Add PJ_3

En espérant vous être utile,

Philippe

[nanie13]

Bonjour
Ma macro fonctionne parfaitement
Merci pour votre aide