Bonjour,

Mon système :
Win7
Outlook / Office 2010
64bits

Je travaille à partir d'un modèle téléchargé sur internet sur une macro VBA qui devrait me permettre de récupérer sur mon disque dur toute l'arborescence, avec les corps de mail, objet et PJ d'une boite de réception Outlook.

Le code actuel ci-dessous, me permet de choisir dans quel répertoire de l'arborescence de la boite de réception démarrer la collecte, puis de choisir l'emplacement de sauvegarde sur mon disque dur, et enfin de lancer la récup des PJ.

C'est un sujet proche du problème posté par teapote mais avec quelques nuances.

Je rencontre 3 besoins non résolus sur la macro actuelle :

-Je souhaite pouvoir filtrer les PJ sauvegardées en éliminant de la requête les fichiers autres que xls, xlsx, ppt, pptx, doc, docx, pdf.
- Je souhaite récupérer le corps et l'objet du mail correspondant dans le répertoire où se sauvegarde chaque PJ.
- Je souhaite insérer l'objet du mail au début du nom de la PJ sauvegardée.

J'ai essayé plusieurs techniques de filtrage d'extension de fichiers etc.. cela ne marche pas, je vous poste donc la macro d'origine sans ces 3 fonctions ci-dessus:

il est nécessaire d'activer Microsoft Scripting Runtime dans l’éditeur VBA d’outlook pour exécuter la macro.
Pour cela, lancer l'éditeur VBA et faire Outils > Références > cocher Microsoft Scripting Runtime dans la liste

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
 
'-- 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
 
    '-- 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
    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
Je précise que je sais qu'il existe des Soft et freeware pour le faire, mais on ne peut en utiliser aucun sur nos postes de travail, donc la seule solution est la macro.

Quelqu'un aurait-il la motivation de jeter un œil ?
Je vous remercie par avance,