Discussion :

[Oliv-]

Bonjour OLIVIER,

Le dossier source "FACTURE" ne figure pas dans ton code. En plus j'ai mis ton code dans un nouveau module mais rien ne s'est passé !

Oui je sais ! je le redis le code doit être associé à une règle. (attention à ce qu'il n'y ait pas une autre règle qui agisse avant!).
Met un point d'arrêt ou le mot "STOP" au début de la macro et tu verras s'il s'exécute.

[LANGAZOU]

Bonjour Oliv-,

Merci pour votre réponse.

je suis débutant en VBA et j'ai pas compri comment mettre le point d'arrêt. j'ai fait uniquement du copier coller

[Oliv-]

Bonjour,
J'ai été débutant aussi ,mais ma réponse ne parle pas que du "point d'arrêt" il faut lire l'ensemble !

Oui je sais ! je le redis le code doit être associé à une règle.

(attention à ce qu'il n'y ait pas une autre règle qui agisse avant!).

Met un point d'arrêt ou le mot "STOP" au début de la macro et tu verras s'il s'exécute.

Pour le "point d'arrêt" et le "mode pas à pas" (f8) tu peux lire cela

[LANGAZOU]

Bonjour Oliv,

Désolé ce code ne fonctionne Toujours pas.

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
Sub REGLE_extrait_PJ_vers_rep(StrID As Outlook.MailItem)
' ***olivier CATTEAU*** script
' 23 avril 2007
'modif 02 06 2015
 
    Dim olNS As Outlook.NameSpace
    Dim Mymail As Outlook.MailItem
    Dim expediteur
    If Not StrID.Class = olMail Then Exit Sub
    Set Mymail = StrID
 
        Stop
 
 
    'MsgBox "nouveau message"
 
    If Mymail.Attachments.Count > 0 Then
        expediteur = Mymail.SenderEmailAddress
 
        'on crée le repertoire où mettre les fichiers joints ##########################################################
        Repertoire = "C:\Users\SEB\Desktop\"
 
        'Repertoire = "C:\TEMP\"
 
        '-- on s'assure de la création / existence du répertoire de stockage
        'AJOUT OLIV- pour classement selon l'année et le mois de réception
        suf = Format(Mymail.ReceivedTime, "YYYY") & "\" & Format(Mymail.ReceivedTime, "YYYY-MM (MMMM)") & "\"
 
        Repertoire = Repertoire & suf
        waaps_creedir (Repertoire)
        'on traite les pj
        Dim pj, TypeAtt
        For Each pj In Mymail.Attachments
            'vérification si c'est une  PJ  Embedded
            'TypeAtt = PJ_Isembedded(pj)
TypeAtt = False
            If TypeAtt = False Then
                N = 1
                MemPath = pj.FileName
                PathNomExport = MemPath
                While Dir(Repertoire & PathNomExport) <> ""
                    'MsgBox "Le fichier " & vbCr & PathNomExport & vbCr & "existe déjà", vbInformation
                    PathNomExport = "(" & N & ")" & MemPath
                    N = N + 1
                Wend
                pj.SaveAsFile Repertoire & PathNomExport
            End If
        Next pj
 
 
        'drapeau vert
        Mymail.FlagIcon = olGreenFlagIcon
        'Marque lu
        Mymail.UnRead = False
        Mymail.Save
        'on déplace le mail vers le sous dossier outlook traité
        On Error Resume Next
        Dim myDestFolder As Outlook.MAPIFolder
        Set myDestFolder = Mymail.Parent.Folders("Traité")
        On Error GoTo 0
        If myDestFolder Is Nothing Then
        Set myDestFolder = Mymail.Parent.Folders.Add("Traité")
        End If
 
        Mymail.Move myDestFolder
 
    End If
    Set Mymail = Nothing
    Set olNS = Nothing
fin:
End Sub
 
Function waaps_creedir(lerep As String) As Boolean
'----------------------------------------------------------------------
' FUNCTION :    waaps_creedir
'               Création d'un répertoire (récursif)
'----------------------------------------------------------------------
' Paramètres :
'   rep :       répertoire à créer par son chemin relatif % au root
'----------------------------------------------------------------------
'   retour :    True si le répertoire est créé
'----------------------------------------------------------------------
' Global utilisé : REP_TOP
'----------------------------------------------------------------------
' COPYRIGHTS : 1994-2005 CAXTON / WAAPS / BRUNO VILLACAMPA
'   Utilisation commerciale interdite
'   Utilisation personnelle / professionnelle autorisée
'   Le message courant doit être préservé
'----------------------------------------------------------------------
    Dim fso As FileSystemObject, i As Integer, retour As Boolean
    Dim rp As String, r
 
    Set fso = CreateObject("Scripting.filesystemobject")
 
    rp = Replace(lerep, "\", "/")
    rp = Replace(rp, "//", "/")
    rep = Split(rp, "/")
    r = REP_TOP
    retour = True
    For i = 0 To UBound(rep)
        If (rep(i) <> "") Then
            r = r & rep(i) & "\"
            If (Not fso.FolderExists(r)) Then
                fso.CreateFolder (CStr(r))
                If (Not fso.FolderExists(r)) Then retour = False
            End If
        End If
    Next
    Set fso = Nothing
    waaps_creedir = retour
End Function

[Oliv-]

Bonjour,
Je vais essayer d'expliquer de nouveau. MERCI DE VALIDER CHAQUE ETAPE !

1. Tu copis le code dans un MODULE
2. Tu écris STOP dans le code : FAIT
3. Tu créés un règle avec les conditions qui répondent à ton besoin.
4. Dans ta règle tu choisi "exécuter un script"
5. Tu vérifies qu'il n'y a pas un autre règle qui s'exécuterait avant.
6. Tu t'envois en Mail qui répond bien aux conditions de ta règle
   --> la macro doit se déclencher et stopper au mot STOP

[LANGAZOU]

Bonjour Olivier,

ca déboge sur la règle ajoutée "STOP". STP est ce que tu peux m'indiquer l'utilité d'ajouter STOP dans le code ?

Merci.

[Oliv-]

Bonjour,
Bon tu as zappé la confirmation que tu avais fait toutes les étapes...

Mais si cela débogue sur le mot STOP cela veut dire que ta règle fonctionne ! appuie sur F5 pour laisser le code s'exécuter entièrement

L'utilité c'est donc de montrer que le code s'exécute bien à la réception d'un mail répondant à la règle!

Tu aurais pu mettre un msgbox aussi !

Code :

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

Msgbox "go"

Le STOP permet ensuite d'exécuter le code en "pas à pas" ça peut être utile pour voir si le code se déroule bien et où on aurait pu faire une erreur de logique.

[LANGAZOU]

Bonjour Olivier ,

Désolé pour ce retard.

votre code marche très bien et c'est grâce à vous que j'ai appris à manipuler des scripts.
Juste un truc: le script efface les mails après avoir copier les PJ. y'a t-il un moyen de garder les mails sans les effacer ?

[Oliv-]

Bonjour,
Heureux d'apprendre que cela fonctionne.

A priori cela n'efface pas les mails mais les déplace dans un sous dossier !

Code :

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

1
2
3
4
5
If myDestFolder Is Nothing Then
        Set myDestFolder = Mymail.Parent.folders.add("Traité")
        End If
 
        Mymail.Move myDestFolder

Il suffit de commenter la ligne (=mettre ' devant) où il y a la .Move

[LANGAZOU]

Merci beaucoup et bonne journée

[Arcanet22]

J'ai récupérer ce code en integrant les references necessaire mais je rencontre l'erreur d'execution 429 : un composant activeX ne peut pas creer l'objet.
Le programme m'a bien crée le dossier temp, mais il semble qu'il ait un problème au niveau de l'alimentation.

Bonjour,
Pourtant il n'y avait qu'une ligne à modifier !

Il faut lancer Extrait_Pieces_Jointes et se laisser guider.

Il y a des limitations à ce code notamment :

une pj ayant le même nom qu'une existante écrasera la première.
Les images dans le corps du Mail sont également exportées.

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
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
'http://www.developpez.net/forums/d1377463/logiciels/microsoft-office/outlook/vba-outlook/macro-vba-sauvegarde-pieces-jointes-p-objets-corps-mail-dossiers/
'-- Variable globale contenant le répertoire de référence de sauvegarde
Dim REP_TOP As String

Sub Extrait_Pieces_Jointes()
'----------------------------------------------------------------------
' Routine :    Extrait_Pieces_Jointes
'----------------------------------------------------------------------
' Paramètres : aucun ...
'----------------------------------------------------------------------
'   retour :    Boite de dialogue "Terminé"
'----------------------------------------------------------------------
' Global utilisé : REP_TOP
'----------------------------------------------------------------------

    Dim myNameSpace As NameSpace, fld As MAPIFolder, pfld As MAPIFolder, sfld As MAPIFolder
    Dim myItem As MailItem, Piece As Attachment
    Dim doc As String, rep As String
Dim test
    '-- Choix et contrôle du disque de destination
    rep = InputBox("Sur quel disque ?", "Question", "C:")
    On Error Resume Next
    ChDrive rep
    test = Err
    On Error GoTo 0

    If test Then
        MsgBox "Disque " & rep & " inaccessible"
        Exit Sub
    End If

    REP_TOP = rep & "\"

    '-- Choix et contrôle / création du répertoire de base
    rep = InputBox("Dans quel répertoire ?", "Question", "\temp\test\")

    test = waaps_creedir(rep)

    If Not test Then
        MsgBox "Répertoire " & rep & " inaccessible"
        Exit Sub
    End If

    '-- Initialisation de la variable globale du répertoire de référence
    REP_TOP = REP_TOP & "\" & rep
    REP_TOP = Replace(REP_TOP, "/", "\")
    REP_TOP = Replace(REP_TOP, "\\", "\")

    '-- Récupération de l'espace nommé MAPI
    Set myNameSpace = CreateObject("Outlook.Application").GetNamespace("MAPI")

    '-- Choix du dossier à traiter ... c'est un MAPIFolder
    Set pfld = myNameSpace.PickFolder

    '-- Si l'utilisateur renonce on s'en va
    If pfld Is Nothing Then Exit Sub

    '-- appel de la routine sauvefolder ...
    sauvefolder pfld, ""

    MsgBox "terminé"

End Sub


Sub sauvefolder(fld As MAPIFolder, ByVal suf As String)
'----------------------------------------------------------------------
' Routine :    sauvefolder (routine récursive...)
'----------------------------------------------------------------------
' Paramètres :
'    fld : Le MAPIFolder à traiter
'    suf : localisation /nomdedossier/nomdedossier2/
'----------------------------------------------------------------------
'   retour :    Aucun
'----------------------------------------------------------------------
' Global utilisé : REP_TOP
'----------------------------------------------------------------------

'-- on entretient la localisation sur la base du nom de dossier courant
    suf = suf & fld.Name & "\"

    '-- On envoie une info dans la fenêtre debug pour ceux qui aiment voir ce qui se passe
    Debug.Print suf & fld.items.Count

    '-- On tourne sur tous les éléments du dossier courant
    For i = 1 To fld.items.Count
        '-- Si c'est un élément de type Mail alors on sauvegarde les pièces jointes associées
        If fld.items(i).Class = olMail Then sauvefichier fld.items(i), suf
        '-- Pour voir ce qui se passe sans tout faire ... enlever le commentaire ci-dessous
        'If i = 2 Then Exit For
    Next

    '-- On tourne sur tous les sous-dossiers du dossier courant
    For i = 1 To fld.folders.Count
        '-- appel récursif de la fonction sauvefolder
        sauvefolder fld.folders(i), suf
    Next

End Sub

Sub sauvefichier(myItem As MailItem, ByVal suf As String)
'----------------------------------------------------------------------
' Routine :    sauvefichier (routine récursive...)
'----------------------------------------------------------------------
' Paramètres :
'    myItem : l'item Mail à traiter
'    suf : localisation /nomdedossier/nomdedossier2/
'----------------------------------------------------------------------
'   retour :    Aucun
'----------------------------------------------------------------------
' Global utilisé : REP_TOP
'----------------------------------------------------------------------

    Dim Piece As Attachment

    '-- on s'assure de la création / existence du répertoire de stockage
    'AJOUT OLIV- pour classement selon l'année et le mois de réception
    suf = Format(myItem.ReceivedTime, "YYYY") & "\" & Format(myItem.ReceivedTime, "YYYY-MM (MMMM)") & "\"
    waaps_creedir (suf)
    

    '-- On boucle sur les pièces jointes du message (si il y en a)
    For j = 1 To myItem.Attachments.Count
        '-- Initialisation de l'objet Pièce Jointe
        Set Piece = myItem.Attachments(j)
        '-- Sauvegarde du fichier correspondant.
        Piece.SaveAsFile REP_TOP & suf & j & "_" & Piece.FileName
    Next
    Set Piece = Nothing
End Sub

Function waaps_creedir(lerep As String) As Boolean
'----------------------------------------------------------------------
' FUNCTION :    waaps_creedir
'               Création d'un répertoire (récursif)
'----------------------------------------------------------------------
' Paramètres :
'   rep :       répertoire à créer par son chemin relatif % au root
'----------------------------------------------------------------------
'   retour :    True si le répertoire est créé
'----------------------------------------------------------------------
' Global utilisé : REP_TOP
'----------------------------------------------------------------------
' COPYRIGHTS : 1994-2005 CAXTON / WAAPS / BRUNO VILLACAMPA
'   Utilisation commerciale interdite
'   Utilisation personnelle / professionnelle autorisée
'   Le message courant doit être préservé
'----------------------------------------------------------------------
    Dim fso As FileSystemObject, i As Integer, retour As Boolean
    Dim rp As String, r

    Set fso = CreateObject("Scripting.filesystemobject")

    rp = Replace(lerep, "\", "/")
    rp = Replace(rp, "//", "/")
    rep = Split(rp, "/")
    r = REP_TOP
    retour = True
    For i = 0 To UBound(rep)
        If (rep(i) <> "") Then
            r = r & rep(i) & "\"
            If (Not fso.FolderExists(r)) Then
                fso.CreateFolder (CStr(r))
                If (Not fso.FolderExists(r)) Then retour = False
            End If
        End If
    Next
    Set fso = Nothing
    waaps_creedir = retour
End Function