Envoi email à partir d'excel

Version imprimable

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):lol:

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. :evilred:

Pourriez-vous m’aider à finaliser cette macro ?

Code:

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:

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

bonsoir

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

Code:

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

30/12/2007, 07h35
nanie13

Envoi email à partir d'excel

Bonjour et merci :king:
Ma macro fonctionne parfaitement :yaisse2:

Envoi email avec PJ à partir d'excel

Re bonjour,

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

Code:

.Attachments.Add PJ_1

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

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

30/12/2007, 16h49
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:

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:

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
30/12/2007, 21h00
nanie13

Envoi email avec PJ à partir d'excel

Bonjour
Ma macro fonctionne parfaitement
Merci pour votre aide