Problème macro enregistrement automatique pièce jointe

**Maloma** · 06/04/2018, 09h06

Bonjour,

Depuis quelques temps j'ai ma macro qui permet d'enregistrer automatiquement les pièces jointes des mails suivant l'objet du message qui ne fonctionne pas tout le temps.
Soit il ne se passe rien, soit elle plante sur la ligne

Code :

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

Set MonMail = MonDossier.Items(nligne)

et de temps en temps tout fonctionne normalement. Du coup je n'ai pas trop d'explication.

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
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
Private Sub Application_NewmailEx(ByVal EntryIDCollection As String)
 
'SAUVEGARDE AUTOMATIQUE DES PIECES JOINTES POUR LES MAILS AIDE CASE OPTIONS OU SEENERGI
 
'DECLARATION DES VARIABLES
Dim MonApp As Outlook.Application 'APPLICATION DE MESSAGERIE
Dim MonNameSpace As Outlook.NameSpace
Dim MonDossier As Outlook.MAPIFolder 'DOSSIER OUTLOOK UTILISE
Dim MonMail As Outlook.MailItem 'OBJET DU MAIL
Dim numero As Integer
Dim PJ As String 'PIECE JOINTE
Dim NbAttachments As Integer 'NOMBRE DE PIECE JOINTE
Dim chemin As String 'DOSSIER D'ENREGISTREMENT DES PIECES JOINTES
Dim nb
Dim fichier 'NOM DU FICHIER ENREGISTRE
Dim nligne
 
    'INSTANCE DES OBJETS
    Set MonApp = Outlook.Application
    Set MonNameSpace = MonApp.GetNamespace("MAPI")
    Set MonDossier = MonNameSpace.GetDefaultFolder(olFolderInbox)
    numero = MonDossier.Items.Count
    nligne = 1
 
    Do While nligne <= numero 'BOUCLE SUR LES MAILS DE LA BOITE DE RECEPTION
        'chemin de destination des pièces jointes
        Set MonMail = MonDossier.Items(nligne)
        NbAttachments = MonMail.Attachments.Count
        'contrôles possibles:nom de l'expéditeur, adresse mail expéditeur et sujet du mail
        'MonMail.SenderName= ""
        'MonMail.SenderEmailAddress
        'MonMail.Subject
 
        'QUAND CONTRAT SEENERGI AIDE CASE
        If MonMail.Subject = "SEENERGI CASE" Then 'CONTROLE SUR L'OBJET DU MESSAGE
 
            chemin = "Z:\DEVELOPPEMENT\CASE\RECEPTION\SEENERGI\"
            i = 1
 
            Do While i <= NbAttachments
                PJ = MonMail.Attachments.Item(i).FileName
 
                    If Right(PJ, 5) = ".xlsx" Then 'ON VERIFIE L'EXTENSION DE LA PJ
                    ' VERIFIER SI LE NOM FICHIER EXISTE DANS LE REPERTOIRE DE DESTINATION SINON L'INCREMENTER
                    fichier = Dir("Z:\DEVELOPPEMENT\CASE\RECEPTION\SEENERGI\" & strAttachment)
                    nb = 0
 
                        Do While fichier <> ""
                            nb = nb + 1
                            fichier = Dir("Z:\DEVELOPPEMENT\CASE\RECEPTION\SEENERGI\" & Left(PJ, Len(PJ) - 5) & "_" & nb & Right(PJ, 5))
                        Loop
 
                        If nb > 0 Then
                            PJ = Left(PJ, Len(PJ) - 5) & "_" & nb & Right(PJ, 5)
                        End If
 
                    MonMail.Attachments.Item(i).SaveAsFile chemin & PJ
                    'AJOUTER UNE NOTE DANS LE CORPS DU MESSAGE QUAND PJ ENREGISTREE
                    MonMail.Body = "----- PIECE JOINTE ENREGISTREE -----" & vbLf & MonMail.Body
                    ' MARQUER LE MESSAGE COMME "LU"
                    MonMail.UnRead = False
                    ' DEPLACER LE MAIL DANS LE DOSSIER CASE
                    MonMail.Move MonDossier.Folders("CASE")
 
                    End If
 
                i = i + 1
            Loop
 
        Else
 
            nligne = nligne + 1
 
        End If
 
        'QUAND BDC OPTONS AIDE CASE
        If MonMail.Subject = "OPTIONS CASE" Then 'CONTROLE SUR L'OBJET DU MESSAGE
 
            chemin = "Z:\DEVELOPPEMENT\CASE\RECEPTION\OPTIONS\"
            i = 1
            Do While i <= NbAttachments
                PJ = MonMail.Attachments.Item(i).FileName
 
                    If Right(PJ, 5) = ".xlsx" Then 'ON VERIFIE L'EXTENSION DE LA PJ
                    ' VERIFIER SI LE NOM FICHIER EXISTE DANS LE REPERTOIRE DE DESTINATION SINON L'INCREMENTER
                    fichier = Dir("Z:\DEVELOPPEMENT\CASE\RECEPTION\OPTIONS\" & PJ)
                    nb = 0
 
                        Do While fichier <> ""
                            nb = nb + 1
                            fichier = Dir("Z:\DEVELOPPEMENT\CASE\RECEPTION\OPTIONS\" & Left(PJ, Len(PJ) - 5) & "_" & nb & Right(PJ, 5))
                        Loop
 
                        If nb > 0 Then
                            PJ = Left(PJ, Len(PJ) - 5) & "_" & nb & Right(PJ, 5)
                        End If
 
                    MonMail.Attachments.Item(i).SaveAsFile chemin & PJ
                    'AJOUTER UNE NOTE DANS LE CORPS DU MESSAGE QUAND PJ ENREGISTREE
                    MonMail.Body = "----- PIECE JOINTE ENREGISTREE -----" & vbLf & MonMail.Body
                    ' MARQUER LE MESSAGE COMME "LU"
                    MonMail.UnRead = False
                    ' DEPLACER LE MAIL DANS LE DOSSIER CASE
                    MonMail.Move MonDossier.Folders("CASE")
 
                    End If
 
                i = i + 1
            Loop
 
        Else
                nligne = nligne + 1
 
        End If
 
        numero = MonDossier.Items.Count
 
    Loop
 
End Sub

Merci pour votre aide

**Oliv-** · 06/04/2018, 11h26

Bonjour,

Que souhaites tu faire au juste ? Est ce que tu veux enregistrer les pj du mail ARRIVANT s'il répond à tes critères ? Alors pourquoi parcours tu toute dans boite de réception ?

en fait tous les items qui sont dans ta BAL ne sont pas des MAIL !

**Maloma** · 06/04/2018, 11h34

Bonjour,

Oui je souhaite enregistrer les pièces jointes des mails arrivant en fonction de l'objet et du format de la pièce jointe.

Je ne suis pas une experte en VBA donc j'ai adapté une macro que j'ai récupéré.

Merci

**Oliv-** · 06/04/2018, 11h48

pour dépanner ton code

il faudrait que tu ajoute un test avant ton Set MonMail = MonDossier.Items(nligne)

Code :

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

        if MonDossier.Items(nligne).class=olmail then

mais je vais t'envoyer un code plus propre

**Oliv-** · 06/04/2018, 12h17

A utiliser avec une règle et l'action [exécuter un script]

Si l'action exécuter un script n'est pas présente il faut faire une modification dans le registre

https://www.slipstick.com/outlook/ru...-script-rules/

ou télécharger directement pour OL2010 : https://www.slipstick.com/doit/Enabl...Rules-2010.reg

Le script à mettre dans un module ( il faut régler le niveau de sécurité à "Notification pour toutes les macros" ou "activer toutes les macros")
https://support.office.com/fr-fr/art...__toc311698312

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
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
 
Sub script_pj_Email(MonMail As MailItem)
 
'SAUVEGARDE AUTOMATIQUE DES PIECES JOINTES POUR LES MAILS AIDE CASE OPTIONS OU SEENERGI
 
'DECLARATION DES VARIABLES
    Dim MonApp As Outlook.Application    'APPLICATION DE MESSAGERIE
    Dim MonNameSpace As Outlook.Namespace
    Dim MonDossier As Outlook.MAPIFolder    'DOSSIER OUTLOOK UTILISE
    Dim MonMail As Outlook.MailItem    'OBJET DU MAIL
    Dim numero As Integer
    Dim PJ As String    'PIECE JOINTE
    Dim NbAttachments As Integer    'NOMBRE DE PIECE JOINTE
    Dim chemin As String    'DOSSIER D'ENREGISTREMENT DES PIECES JOINTES
    Dim nb
    Dim fichier    'NOM DU FICHIER ENREGISTRE
    Dim nligne
 
    'INSTANCE DES OBJETS
    Set MonApp = Outlook.Application
    Set MonNameSpace = MonApp.GetNamespace("MAPI")
    Set MonDossier = MonNameSpace.GetDefaultFolder(olFolderInbox)
    numero = MonDossier.Items.Count
    NbAttachments = MonMail.Attachments.Count
    'contrôles possibles:nom de l'expéditeur, adresse mail expéditeur et sujet du mail
    'MonMail.SenderName= ""
    'MonMail.SenderEmailAddress
    'MonMail.Subject
 
    'QUAND CONTRAT SEENERGI AIDE CASE
    If MonMail.Subject = "SEENERGI CASE" Then    'CONTROLE SUR L'OBJET DU MESSAGE
 
        chemin = "Z:\DEVELOPPEMENT\CASE\RECEPTION\SEENERGI\"
        i = 1
 
        Do While i <= NbAttachments
            PJ = MonMail.Attachments.Item(i).Filename
 
            If Right(PJ, 5) = ".xlsx" Then    'ON VERIFIE L'EXTENSION DE LA PJ
                ' VERIFIER SI LE NOM FICHIER EXISTE DANS LE REPERTOIRE DE DESTINATION SINON L'INCREMENTER
                fichier = Dir("Z:\DEVELOPPEMENT\CASE\RECEPTION\SEENERGI\" & strAttachment)
                nb = 0
 
                Do While fichier <> ""
                    nb = nb + 1
                    fichier = Dir("Z:\DEVELOPPEMENT\CASE\RECEPTION\SEENERGI\" & Left(PJ, Len(PJ) - 5) & "_" & nb & Right(PJ, 5))
                Loop
 
                If nb > 0 Then
                    PJ = Left(PJ, Len(PJ) - 5) & "_" & nb & Right(PJ, 5)
                End If
 
                MonMail.Attachments.Item(i).SaveAsFile chemin & PJ
                'AJOUTER UNE NOTE DANS LE CORPS DU MESSAGE QUAND PJ ENREGISTREE
                MonMail.Body = "----- PIECE JOINTE ENREGISTREE -----" & vbLf & MonMail.Body
                ' MARQUER LE MESSAGE COMME "LU"
                MonMail.UnRead = False
                ' DEPLACER LE MAIL DANS LE DOSSIER CASE
                MonMail.Move MonDossier.Folders("CASE")
 
            End If
 
            i = i + 1
        Loop
 
 
 
 
        'QUAND BDC OPTONS AIDE CASE
    ElseIf MonMail.Subject = "OPTIONS CASE" Then    'CONTROLE SUR L'OBJET DU MESSAGE
 
        chemin = "Z:\DEVELOPPEMENT\CASE\RECEPTION\OPTIONS\"
        i = 1
        Do While i <= NbAttachments
            PJ = MonMail.Attachments.Item(i).Filename
 
            If Right(PJ, 5) = ".xlsx" Then    'ON VERIFIE L'EXTENSION DE LA PJ
                ' VERIFIER SI LE NOM FICHIER EXISTE DANS LE REPERTOIRE DE DESTINATION SINON L'INCREMENTER
                fichier = Dir("Z:\DEVELOPPEMENT\CASE\RECEPTION\OPTIONS\" & PJ)
                nb = 0
 
                Do While fichier <> ""
                    nb = nb + 1
                    fichier = Dir("Z:\DEVELOPPEMENT\CASE\RECEPTION\OPTIONS\" & Left(PJ, Len(PJ) - 5) & "_" & nb & Right(PJ, 5))
                Loop
 
                If nb > 0 Then
                    PJ = Left(PJ, Len(PJ) - 5) & "_" & nb & Right(PJ, 5)
                End If
 
                MonMail.Attachments.Item(i).SaveAsFile chemin & PJ
                'AJOUTER UNE NOTE DANS LE CORPS DU MESSAGE QUAND PJ ENREGISTREE
                MonMail.Body = "----- PIECE JOINTE ENREGISTREE -----" & vbLf & MonMail.Body
                ' MARQUER LE MESSAGE COMME "LU"
                MonMail.UnRead = False
                ' DEPLACER LE MAIL DANS LE DOSSIER CASE
                MonMail.Move MonDossier.Folders("CASE")
            End If
            i = i + 1
        Loop
End Sub

**Maloma** · 06/04/2018, 14h06

Merci,
je viens de créer ma règle avec ton script, je vais devoir attendre de recevoir de nouveaux mails avec mes critères pour vérifier que je n'ai plus de problème.

En attendant je te remercie pour ton aide.

Bonne journée

**isachiara** · 15/10/2018, 13h36

Bonjour

Je souhaiterais savoir si le code a fonctionné pour vous ?

Je suis novice en VBA et je souhaiterais le recopier .

Egalement j'ai déjà écrit un script pour imprimer des pièces jointes ; il se trouve dans 1 module 1 d'1 projet 1

Est ce que je dois créer un projet 2 pour y inclure votre code ( dans ce cas , je ne sais pas comment on fait ) ou bien est ce que je peux mettre votre code dans 1 module 2 du projet 1 ?

Merci par avance

**Oliv-** · 15/10/2018, 14h04

Envoyé par isachiara

...ou bien est ce que je peux mettre votre code dans 1 module 2 du projet 1 ?

Merci par avance

Bonjour, oui c'est bien cela.

**isachiara** · 15/10/2018, 17h17

Envoyé par Oliv-

Bonjour, oui c'est bien cela.

bonjour merci pour la réponse. quand est ce qu'on crée un projet 2 , à quoi sert si on peut tout mettre dans le projet 1? Et également comment créé t on un projet 2 ?

**Oliv-** · 15/10/2018, 17h33

On peut avoir plusieurs projets (fichiers VBPAPROJECT.otm ou "autre nom".otm) mais on ne peut en utiliser que 1 à la fois.

pour des tests ou des développements pour d'autres personnes par exemple.

**isachiara** · 15/10/2018, 17h53

Envoyé par Oliv-

On peut avoir plusieurs projets (fichiers VBPAPROJECT.otm ou "autre nom".otm) mais on ne peut en utiliser que 1 à la fois.

pour des tests ou des développements pour d'autres personnes par exemple.

Merci beaucoup. du coup quand je fais une règle avec un script cela va tester tous les modules du projet 1? Car si n'affecte un script cela ne me propose que le projet 1...

**Oliv-** · 16/10/2018, 09h36

OUI tu peux avoir des centaines de macros dans tes modules, par contre pour l'option de règle "exécuter un script" il faut que ce soit une macro avec des paramètres ce qui est entre parenthèse.

Code :

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

1
2
3
4
Sub Script_reponse_BadMail(MyMail As Outlook.MailItem)
 
msgbox MyMail.subject
End sub

**isachiara** · 16/10/2018, 18h43

Merci donc 1 macro, c'est ce que je trouve dans le module si je comprends bien.
Et est ce normal que quand je clique sur " exécuter 1 script "dans 1 règle outlook, cela ne propose que 1 projet , à l’intérieur duquel j'ai plusieurs modules ?
Désolée mais je débute ! je repose un peu la même question pour être certaine d'avoir tout compris :
a l’intérieur d'1 projet 1 je peux avoir 1 module qui me dit que pour tartampion, il faut imprimer le pdf et 1 autre module qui me dit que pour chatounette il faut enregistrer la pièce jointe dans tel dossier de mon pc .... etc ?

**Oliv-** · 17/10/2018, 09h31

OUI

**isachiara** · 17/10/2018, 11h22

Envoyé par Oliv-

OUI

merci

peux tu m'expliquer les différences entre es mots

script
macro
code

pour que je comprenne bien ?

Merci !

**Oliv-** · 17/10/2018, 14h46

c'est plus ou moins des synonymes.

**Steph92-44** · 23/08/2019, 14h39

Merci Oliv' ! C'est exactement ce que je cherchais, je vais essayer de l'adapter, notamment pour faire appliquer cette règle sur les nouveaux messages entrants. Faut-il modifier le code, ou est-ce que la règle fera que le code ne s'applique que sur le mail qui vient d'arriver ?

Merci par avance pour ton aide,

Stéphane

Envoyé par Oliv-

A utiliser avec une règle et l'action [exécuter un script]

Si l'action exécuter un script n'est pas présente il faut faire une modification dans le registre

https://www.slipstick.com/outlook/ru...-script-rules/

ou télécharger directement pour OL2010 : https://www.slipstick.com/doit/Enabl...Rules-2010.reg

Le script à mettre dans un module ( il faut régler le niveau de sécurité à "Notification pour toutes les macros" ou "activer toutes les macros")
https://support.office.com/fr-fr/art...__toc311698312

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
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
 
Sub script_pj_Email(MonMail As MailItem)
 
'SAUVEGARDE AUTOMATIQUE DES PIECES JOINTES POUR LES MAILS AIDE CASE OPTIONS OU SEENERGI
 
'DECLARATION DES VARIABLES
    Dim MonApp As Outlook.Application    'APPLICATION DE MESSAGERIE
    Dim MonNameSpace As Outlook.Namespace
    Dim MonDossier As Outlook.MAPIFolder    'DOSSIER OUTLOOK UTILISE
    Dim MonMail As Outlook.MailItem    'OBJET DU MAIL
    Dim numero As Integer
    Dim PJ As String    'PIECE JOINTE
    Dim NbAttachments As Integer    'NOMBRE DE PIECE JOINTE
    Dim chemin As String    'DOSSIER D'ENREGISTREMENT DES PIECES JOINTES
    Dim nb
    Dim fichier    'NOM DU FICHIER ENREGISTRE
    Dim nligne
 
    'INSTANCE DES OBJETS
    Set MonApp = Outlook.Application
    Set MonNameSpace = MonApp.GetNamespace("MAPI")
    Set MonDossier = MonNameSpace.GetDefaultFolder(olFolderInbox)
    numero = MonDossier.Items.Count
    NbAttachments = MonMail.Attachments.Count
    'contrôles possibles:nom de l'expéditeur, adresse mail expéditeur et sujet du mail
    'MonMail.SenderName= ""
    'MonMail.SenderEmailAddress
    'MonMail.Subject
 
    'QUAND CONTRAT SEENERGI AIDE CASE
    If MonMail.Subject = "SEENERGI CASE" Then    'CONTROLE SUR L'OBJET DU MESSAGE
 
        chemin = "Z:\DEVELOPPEMENT\CASE\RECEPTION\SEENERGI\"
        i = 1
 
        Do While i <= NbAttachments
            PJ = MonMail.Attachments.Item(i).Filename
 
            If Right(PJ, 5) = ".xlsx" Then    'ON VERIFIE L'EXTENSION DE LA PJ
                ' VERIFIER SI LE NOM FICHIER EXISTE DANS LE REPERTOIRE DE DESTINATION SINON L'INCREMENTER
                fichier = Dir("Z:\DEVELOPPEMENT\CASE\RECEPTION\SEENERGI\" & strAttachment)
                nb = 0
 
                Do While fichier <> ""
                    nb = nb + 1
                    fichier = Dir("Z:\DEVELOPPEMENT\CASE\RECEPTION\SEENERGI\" & Left(PJ, Len(PJ) - 5) & "_" & nb & Right(PJ, 5))
                Loop
 
                If nb > 0 Then
                    PJ = Left(PJ, Len(PJ) - 5) & "_" & nb & Right(PJ, 5)
                End If
 
                MonMail.Attachments.Item(i).SaveAsFile chemin & PJ
                'AJOUTER UNE NOTE DANS LE CORPS DU MESSAGE QUAND PJ ENREGISTREE
                MonMail.Body = "----- PIECE JOINTE ENREGISTREE -----" & vbLf & MonMail.Body
                ' MARQUER LE MESSAGE COMME "LU"
                MonMail.UnRead = False
                ' DEPLACER LE MAIL DANS LE DOSSIER CASE
                MonMail.Move MonDossier.Folders("CASE")
 
            End If
 
            i = i + 1
        Loop
 
 
 
 
        'QUAND BDC OPTONS AIDE CASE
    ElseIf MonMail.Subject = "OPTIONS CASE" Then    'CONTROLE SUR L'OBJET DU MESSAGE
 
        chemin = "Z:\DEVELOPPEMENT\CASE\RECEPTION\OPTIONS\"
        i = 1
        Do While i <= NbAttachments
            PJ = MonMail.Attachments.Item(i).Filename
 
            If Right(PJ, 5) = ".xlsx" Then    'ON VERIFIE L'EXTENSION DE LA PJ
                ' VERIFIER SI LE NOM FICHIER EXISTE DANS LE REPERTOIRE DE DESTINATION SINON L'INCREMENTER
                fichier = Dir("Z:\DEVELOPPEMENT\CASE\RECEPTION\OPTIONS\" & PJ)
                nb = 0
 
                Do While fichier <> ""
                    nb = nb + 1
                    fichier = Dir("Z:\DEVELOPPEMENT\CASE\RECEPTION\OPTIONS\" & Left(PJ, Len(PJ) - 5) & "_" & nb & Right(PJ, 5))
                Loop
 
                If nb > 0 Then
                    PJ = Left(PJ, Len(PJ) - 5) & "_" & nb & Right(PJ, 5)
                End If
 
                MonMail.Attachments.Item(i).SaveAsFile chemin & PJ
                'AJOUTER UNE NOTE DANS LE CORPS DU MESSAGE QUAND PJ ENREGISTREE
                MonMail.Body = "----- PIECE JOINTE ENREGISTREE -----" & vbLf & MonMail.Body
                ' MARQUER LE MESSAGE COMME "LU"
                MonMail.UnRead = False
                ' DEPLACER LE MAIL DANS LE DOSSIER CASE
                MonMail.Move MonDossier.Folders("CASE")
            End If
            i = i + 1
        Loop
End Sub

**Oliv-** · 30/08/2019, 12h30

Bonjour,
Le script se lancera sur chaque nouveau mail répondant à la règle définie.

Problème macro enregistrement automatique pièce jointe

VBA Outlook

Discussions similaires

Partager

Partager