Ajouter pièce jointe automatiquement (Macro)

**masterp51** · 10/02/2013, 12h54

Bonjour,

Avec outlook 2010, une application tierce crée et envoie des mails dans la boite d'envoi d'Outlook 2010 (Mise en attente d'envoi).

Est il possible avec un bouton macro, de joindre toujours la même pièce jointe à ces mails créés par l'appli tierce, en faisant une routine analysant le contenu de l'objet des mails dans la boite d'envoi.(Exemple de l'obet: Mail créé par Appli...)

Si le texte de l'objet 'Mail créé par Appli' est trouvé alors:
- Ouvrir le mail (Sans le modifier)
- Insérer la pièce jointe

J'espère être assez clair. Merci de votre aide

**Oliv-** · 12/02/2013, 10h53

A mettre dans ThisOutlookSession

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
 
Private Sub Application_ItemSend(ByVal item As Object, Cancel As Boolean)
'by oliv modifiée le 12/2/2013
 
    Dim prompt As String
    Dim taille, pieces
    Dim objNS As NameSpace
    Dim objFolder As MAPIFolder
 
    ' on verifie que c'est un mail
    If Not item.Class = olMail Then GoTo fin
 
     '###########verification SI PUBLIPOSTAGE #################################
    If UCase(item.subject) Like "*PUBLIPOSTAGE*" Then
        On Error Resume Next
        'Pour ajouter la même PJ à tous
        item.Attachments.Add Source:= _
         "d:\temp\DOC2.PDF"
        'Pour ajouter un document personnalisé d'après le destinataire _
         du mail décommenter
        ' ici le nom du document est "destinataire@domaine.fr.doc"
        'docperso = "d:\temp\monmailing\" & item.To & ".doc"
        'item.Attachments.Add Source:=docperso
 
        'On sauvegarde le mail
        item.Save
        'on va directement à la fin pour éviter les questions sur l'envoi
        GoTo fin
    End If
 
    '#######FIN #######
fin:
 
    Set item = Nothing
 
End Sub

**masterp51** · 13/02/2013, 11h15

Bonjour et un grand merci pour votre solution.

Désolé mais cela ne fonctionne pas, lorsque je fais envoyer/recevoir la pièce jointe ne s'insére pas, rien ne se passe... Pouvez vous m'aider à trouver l'erreur que je fais?

Dans ThisOutlookSession, j'ai copié ceci:

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
Private Sub Application_ItemSend(ByVal item As Object, Cancel As Boolean)
 
 
    Dim prompt As String
    Dim taille, pieces
    Dim objNS As NameSpace
    Dim objFolder As MAPIFolder
 
    ' on verifie que c'est un mail
    If Not item.Class = olMail Then GoTo fin
 
    If UCase(item.Subject) Like "*Facture N° F*" Then
        On Error Resume Next
        'Pour ajouter la même PJ à tous
        item.Attachments.Add Source:= _
         "c:\cgv\cgv.PDF"
 
 'Pour ajouter un document personnalisé d'après le destinataire _
         du mail décommenter
        ' ici le nom du document est "destinataire@domaine.fr.doc"
        'docperso = "d:\temp\monmailing\" & item.To & ".doc"
        'item.Attachments.Add Source:=docperso
 
        'On sauvegarde le mail
        item.Save
        'on va directement à la fin pour éviter les questions sur l'envoi
        GoTo fin
    End If
 
    '#######FIN #######
fin:
 
    Set item = Nothing
 
End Sub

**carden752** · 13/02/2013, 15h33

Bonjour,

La fonction Ucase retourne une chaine en majuscule donc la comparaison suivante est toujours fausse.

Code :

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

 If UCase(item.Subject) Like "*Facture N° F*" Then

à remplacer par

Code :

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

 If UCase(item.Subject) Like "*FACTURE N° F*" Then

**masterp51** · 13/02/2013, 16h05

Merci Christophe pour l'aide, mais malgré la modif proposée, le pb est identique. Le fichier joint ne s'insére pas, pourtant la macro se lance bien lorsque je fais 'Envoyer'...

**carden752** · 13/02/2013, 17h51

Bonjour,

Enlève le message permettant de passer sur les erreurs

Code :

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

On error resume Next

Et dis nous quelle est la ligne qui provoque une erreur, s'il y en a une.

**masterp51** · 14/02/2013, 10h46

Erreur 446
Cet objet ne gère pas les arguments nommés:

item.Attachments.Add Source:= _
"c:\cgv\cgv.PDF"

**carden752** · 14/02/2013, 11h38

Bonjour,

Il faut passer par un objet intermédiaire de type Mailitem

Code :

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

1
2
3
4
dim monmail as MailItem
set monmail=item
monmail.attachments.add source:= _
"c:\cgv\cgv.PDF"

**Oliv-** · 14/02/2013, 12h17

Bonjour,

Voici qui doit fonctionner :

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
Private Sub Application_ItemSend(ByVal item As Object, Cancel As Boolean)
 
 
    Dim prompt As String
    Dim taille, pieces
    Dim objNS As NameSpace
    Dim objFolder As MAPIFolder
 
    ' on verifie que c'est un mail
    If Not item.Class = olMail Then GoTo fin
 
    If UCase(item.Subject) Like "*FACTURE N° F*" Then
        'On Error Resume Next
        'Pour ajouter la même PJ à tous
        item.Attachments.Add "c:\cgv\cgv.PDF"
 
 'Pour ajouter un document personnalisé d'après le destinataire _
         du mail décommenter
        ' ici le nom du document est "destinataire@domaine.fr.doc"
        'docperso = "d:\temp\monmailing\" & item.To & ".doc"
        'item.Attachments.Add Source:=docperso
 
        'On sauvegarde le mail
        item.Save
        'on va directement à la fin pour éviter les questions sur l'envoi
        GoTo fin
    End If
 
    '#######FIN #######
fin:
 
    Set item = Nothing
 
End Sub

**Oliv-** · 14/02/2013, 12h19

Envoyé par carden752

Bonjour,

Il faut passer par un objet intermédiaire de type Mailitem

Code :

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

1
2
3
4
dim monmail as MailItem
set monmail=item
monmail.attachments.add source:= _
"c:\cgv\cgv.PDF"

c'est effectivement parce que item As Object et pas MailItem

**masterp51** · 14/02/2013, 13h21

Super le code ci-dessous fonctionne... Merci à tous.

Une derniere question, comment utiliser 'Facture N° F' en respectant strictement la casse ('F' majuscules, 'acture' en minuscules, etc..).
La casse de cet objet est créé automatiquement par l'application tierce...
Merci à vous.

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
 Dim prompt As String
    Dim taille, pieces
    Dim objNS As NameSpace
    Dim objFolder As MAPIFolder
 
    ' on verifie que c'est un mail
    If Not item.Class = olMail Then GoTo fin
 
    If UCase(item.Subject) Like "*FACTURE N° F*" Then
        'On Error Resume Next
        'Pour ajouter la même PJ à tous
        item.Attachments.Add "c:\cgv\cgv.PDF"
 
 'Pour ajouter un document personnalisé d'après le destinataire _
         du mail décommenter
        ' ici le nom du document est "destinataire@domaine.fr.doc"
        'docperso = "d:\temp\monmailing\" & item.To & ".doc"
        'item.Attachments.Add Source:=docperso
 
        'On sauvegarde le mail
        item.Save
        'on va directement à la fin pour éviter les questions sur l'envoi
        GoTo fin
    End If
 
    '#######FIN #######
fin:
 
    Set item = Nothing
 
End Sub

**carden752** · 14/02/2013, 14h07

Bonjour,

Il suffit de ne pas utiliser la fonction Ucase mais comparer directement item.subject

Code :

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

 If item.Subject Like "*Facture N° F*" Then

**masterp51** · 14/02/2013, 14h45

Merci encore à tous pour la solution et le temps passé...

**DISTRIFC** · 02/12/2015, 15h20

Bonjour,
je n'arrive pas à faire fonctionner ce code dans outlook 2013.Les macros sont bien activés. est ce un problème de compatibilité ?

**Oliv-** · 02/12/2015, 17h10

salut,
où as tu placé ce code ?

**DISTRIFC** · 03/12/2015, 09h32

Envoyé par Oliv-

salut,
où as tu placé ce code ?

Salut.
dans thisoutlooksession

Nom : Microsoft Visual Basic pour Applications - VbaProject.OTM.jpg
Affichages : 4261
Taille : 65,6 Ko

**Oliv-** · 03/12/2015, 10h54

Bonjour,
Peux tu publier le code que tu utilises ?

**DISTRIFC** · 03/12/2015, 11h30

Envoyé par Oliv-

Bonjour,
Peux tu publier le code que tu utilises ?

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
 
Dim prompt As String
    Dim taille, pieces
    Dim objNS As NameSpace
    Dim objFolder As MAPIFolder
 
    ' on verifie que c'est un mail
    If Not Item.Class = olMail Then GoTo fin
 
    If UCase(Item.Subject) Like "*TARIF 42*" Then
      On Error Resume Next
        'Pour ajouter la même PJ à tous
        Item.Attachments.Add "c:\TEST.PDF"
 
 'Pour ajouter un document personnalisé d'après le destinataire _
         du mail décommenter
        ' ici le nom du document est "destinataire@domaine.fr.doc"
        'docperso = "d:\temp\monmailing\" & item.To & ".doc"
        'item.Attachments.Add Source:=docperso
 
        'On sauvegarde le mail
        Item.Save
        'on va directement à la fin pour éviter les questions sur l'envoi
        GoTo fin
    End If
 
    '#######FIN #######
fin:
 
    Set Item = Nothing
 
End Sub

**Oliv-** · 03/12/2015, 11h34

ta procédure doit s'appeler

Code :

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

Private Sub Application_ItemSend(ByVal item As Object, Cancel As Boolean)

c'est une procédure événementielle !

**DISTRIFC** · 03/12/2015, 11h53

Envoyé par Oliv-

ta procédure doit s'appeler

Code :

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

Private Sub Application_ItemSend(ByVal item As Object, Cancel As Boolean)

c'est une procédure événementielle !

Évidemment quel boulet je fais, merci beaucoup.cela est fonctionnel maintenant.

Ajouter pièce jointe automatiquement (Macro) [OL-2010]

VBA Outlook

Discussions similaires

Partager

Partager