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 |
