Bug lors de l'ajout d'une PJ dans un mail à partir d'Excel

Version imprimable

Bonjour,

J'ai adapté le code suivant :

L'envoi par mail fonctionne mais sur les 12 mails que je devais envoyer, le premier envoie sa PJ comme prévu, mais le deuxième mail envoie sa PJ et celle du premier, le 3eme, sa pj et les deux précédentes. Etc.

PieceJointe = Range("e" & Ligne) envoi à une cellule où l'adresse du fichier est stocké sous forme de ="serveur\chemin\nomdufichier.pdf".

J'ai essayé de forcer une RAZ avec PieceJointe = "" mais c'est ko.

Une idée ?
Merci

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
Public Sub CDOMail()
 
    Dim Mail    As CDO.Message
    Dim Config  As CDO.Configuration
    Dim Ligne As Integer
 
    Set Mail = CreateObject("CDO.Message")
    Set Config = CreateObject("CDO.Configuration")
 
    Config.Fields(cdoSendUsingMethod).Value = 2
    Config.Fields(cdoSMTPServer).Value = "xxxx"
    Config.Fields(cdoSMTPServerPort).Value = 25
    Config.Fields.Update
 
    Set Mail.Configuration = Config
 
    For Ligne = 8 To Cells(Rows.Count, 2).End(xlUp).Row
 
    PieceJointe = Range("e" & Ligne)
 
    With Mail
        .To = xxx
'        .CC = xxx
        .From = xxx
        .Subject = Range("c2") & Range("d" & Ligne)
        .TextBody = Range("c3")
 
        .AddAttachment (PieceJointe)
 
        .Send
    End With
 
    PieceJointe = ""
 
    Next Ligne
 
    MsgBox Ligne - 8 & " fichiers ont été envoyés par mail"
 
    Set Config = Nothing
    Set Mail = Nothing
 
End Sub

09/05/2022, 12h23
laurent_ott

Bonjour,
Une idée : après l'envoi du mail, supprimer l'objet après la ligne 33 (set mail = Nothing)
Puis générer un nouveau objet (vos lignes 7 et 15)

Bonne continuation.

Citation:

Envoyé par laurent_ott

Bonjour,
Une idée : après l'envoi du mail, supprimer l'objet après la ligne 33 (set mail = Nothing)
Puis générer un nouveau objet (vos lignes 7 et 15)

Bonne continuation.

Bonjour,

Ca a parfaitement fonctionné. Un grand merci :)

Je donne le code modifié si cela intéresse qqlun :

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
 
 
Public Sub CDOMail()
 
    Dim Mail    As CDO.Message
    Dim Config  As CDO.Configuration
    Dim Ligne As Integer
 
    Set Config = CreateObject("CDO.Configuration")
 
    Config.Fields(cdoSendUsingMethod).Value = 2
    Config.Fields(cdoSMTPServer).Value = "xxx"
    Config.Fields(cdoSMTPServerPort).Value = 25
    Config.Fields.Update
 
 
    For Ligne = 8 To Cells(Rows.Count, 2).End(xlUp).Row 'plage données : à partir de la ligne 8 jusqu'à la dernière valeur en colonne 1
 
    Set Mail = CreateObject("CDO.Message")
    Set Mail.Configuration = Config
 
    PieceJointe = Range("e" & Ligne) 'pièce jointe = valeurs en colonne e (colonne + n° de la ligne traitée)
 
    With Mail
        .To = xxx
'        .CC = xxx
        .From = xxx        .Subject = Range("c2") & Range("d" & Ligne)
        .TextBody = Range("c3")
 
        .AddAttachment (PieceJointe)
 
        .Send
    End With
 
    PieceJointe = ""
    Set Mail = Nothing
 
    Next Ligne
 
    MsgBox Ligne - 8 & " fichiers ont été envoyés par mail"
 
    Set Config = Nothing
 
 
End Sub