Importer les fichiers d'un dossier Outlook Express

**e040098k** · 23/09/2008, 10h40

Bonjour,

Je récupère le nom d'un dossier outlook pour en importer les fichiers grace à ces quelques ligne:s

Code :

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

1
2
3
4
5
6
7
8
    '-- 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

J'aimerais faire la même chose sur Outlook Express! (tous mes collègues n'ont pas Outlook !)

Savez-vous si cela est possible ?

**e040098k** · 23/09/2008, 21h29

Bon! Je vois que mon sujet n'inspire pas le plus grand nombre !

J'ai fouiné un peu et ai trouvé ce code qui me permet de lister les dossiers de outlook express en récupérant leur numéro!

Il faudrait remplir un treeview avec ! Cela ne resoud pas encore mon probleme mais c'est un début!

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
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
'Ce code sert à récupérer le numero des dossiers gérés par outlook express.
'A chaque dossier est attribué un code qui est enfoui dans le fichier folders.dbx
Option Explicit
Private Const ERROR_NONE = 0
Private Const HKEY_CURRENT_USER = &H80000001
Private Const KEY_ALL_ACCESS = &H3F
Private Const FolderName = "Folders.dbx"
Private Type TreeHeader_Record
  ChildNode As Long
  EntriesNumber As Integer
End Type
Private Type FolderInfo_Record
    OEName As String
    RegInfo As String
End Type
Private FoldersNumber As Integer
Private iFolder As Integer
Private RootPtr As Long
Private KeyName As String
Private FoldersPath As String
Private FolderInfo() As FolderInfo_Record
Private Declare Function RegOpenKeyEx Lib "advapi32.dll" Alias "RegOpenKeyExA" (ByVal hKey As Long, _
ByVal lpSubKey As String, ByVal ulOptions As Long, ByVal samDesired As Long, phkResult As Long) As Long
Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
Private Declare Function RegQueryValueExNULL Lib "advapi32.dll" Alias "RegQueryValueExA" _
(ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, _
ByVal lpData As Long, lpcbData As Long) As Long
Private Declare Function RegQueryValueExString Lib "advapi32.dll" Alias "RegQueryValueExA" _
(ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, _
ByVal lpData As String, lpcbData As Long) As Long
 
Private Sub Test()
On Error GoTo ErrorTag
  'Détermination de l'emplacement de Folders.dbx
  If Not FindFolders Then
      MsgBox "Je ne trouve pas de fichiers Folders.dbx"
      End
  Else: Folders 'Adresses des dossiers
  End If
  Exit Sub
 
ErrorTag:
  MsgBox Error, , "Form_Load"
End Sub
'------------------------------------ Folders
Private Function Folders() As Boolean
Dim i As Integer, j As Integer
Dim S As String
'Dim si As ListSubItem
'Dim li As ListItem
  On Error GoTo ErrorTag
 
  ReDim FolderInfo(1)
  Open FoldersPath & "\" & FolderName For Binary Access Read As #1
  Seek #1, &H24BD
  S = Input(8, #1)
  S = BinToHexa(S)
  iFolder = 1
  RootPtr = ReadFoldersHead
  ReadFolder RootPtr
 
  Open "Trace.txt" For Output As 2
  ' Edite les caractéristiques des dossiers lus
  For i = 1 To FoldersNumber
    With FolderInfo(i)
      'Enregistrement et affichage
      Write #2, .OEName; S & .RegInfo
 
      MsgBox "Le Dossier " & .OEName & " porte le code : " & .RegInfo
      'Définit la couleur rouge pour la propriété de la seconde colonne
      'si.ForeColor = vbRed
    End With
  Next i
  Close
 
  Exit Function
ErrorTag:
  MsgBox Error, , "Folders"
End Function
 
Private Function FindFolders() As Boolean
Dim hKey As Long, RetVal As Long  ',PtrRacine As Long, i As Long
Dim Identity As String, S As String
  On Error GoTo Erreur
 
  KeyName = "Identities\"
  RetVal = OpenKey(KeyName, hKey)
  If RetVal <> ERROR_NONE Then GoTo Echec
  RetVal = GetKeyValue(hKey, "Last User ID", Identity, "Identity")
  RegCloseKey hKey
  If RetVal <> ERROR_NONE Then GoTo Echec
 
  KeyName = KeyName & Identity & "\"
  RetVal = OpenKey(KeyName, hKey)
  If RetVal <> ERROR_NONE Then GoTo Echec
  RegCloseKey hKey
 
  'détermination du chemin du dossier de stockage 'recherche de Folders.dbx)
  KeyName = KeyName & "Software\Microsoft\Outlook Express\5.0\"
  RetVal = OpenKey(KeyName, hKey)
  If RetVal <> ERROR_NONE Then GoTo Echec
  RetVal = GetKeyValue(hKey, "Store Root", FoldersPath)
  'supprimer le dernier \ éventuel modification du 27/1/07
  If Right$(FoldersPath, 1) = "\" Then FoldersPath = Left$(FoldersPath, Len(FoldersPath) - 1)
  RegCloseKey hKey
  'convertir les variables d'environnement s'il y en a
  If Left$(FoldersPath, 1) = "%" Then
    Dim Start As Byte
    Start = InStr(2, FoldersPath, "%")
    S = Mid$(FoldersPath, 2, Start - 2)
    FoldersPath = Environ(S) & Mid$(FoldersPath, Start + 1)
  End If
 
  MsgBox FoldersPath
  FindFolders = True
 
  Exit Function
Erreur:
  'Resume Next
  FindFolders = False
  Close 1
  MsgBox "Erreur de lecture du fichier Folders.dbx", vbCritical, "Folders"
  Exit Function
Echec:
  S = "Il n'existe aucune identité ou le registre est endommagé." & vbCr & vbCr & "Le programme va être interrompu !"
  MsgBox S, vbCritical, "FindFolders": End
End Function
Private Sub ReadFolder(Ind As Long)
Dim i As Long, j As Long
Dim Zone As String, ZoneHexa As String
Dim TreeHeader As TreeHeader_Record
  On Error GoTo ErrorTag
 
  TreeHeader = ReadTreeHead(Ind)
  For i = 1 To TreeHeader.EntriesNumber
    Seek #1, (Ind + &H18 + 1 + (i - 1) * 12)
    Zone = Input(4, #1)
    ZoneHexa = BinToHexa(Zone)
    j = Hexa8ToBin(ZoneHexa)
    FolderInfo(iFolder) = ReadIndexInfo(j)
    iFolder = iFolder + 1
    ReDim Preserve FolderInfo(iFolder)
    Seek #1, (Ind + &H1C + 1 + (i - 1) * 12)
    Zone = Input(4, #1)
    ZoneHexa = BinToHexa(Zone)
    j = Hexa8ToBin(ZoneHexa)
    If j <> 0 Then ReadFolder j
  Next
  If TreeHeader.ChildNode <> 0 Then ReadFolder TreeHeader.ChildNode
 
  ' si plusieurs arbres voir les conséquences
  FoldersNumber = iFolder - 1
 
  Exit Sub
ErrorTag:
  MsgBox Error, , "ReadFolder"
End Sub
Private Function ReadIndexInfo(Ptr As Long) As FolderInfo_Record
Dim i1 As Integer, i2 As Integer, i As Integer, V As Integer, EntriesNumber As Integer
Dim BeginTable(19) As Integer, EndTable(19) As Integer
Dim L As Long, IndexLength As Long
Dim Zone As String, ZoneHexa As String, ZoneParamD As String, ZoneParamI As String, CodeText As String
Dim R As FolderInfo_Record
  On Error GoTo ErrorTag
 
  ' recherche marqueur
  Seek #1, Ptr + 1
  Zone = Input(4, #1)
  ZoneHexa = BinToHexa(Zone)
  If Hexa8ToBin(ZoneHexa) <> Ptr Then GoTo ErrorTag
 
  Seek #1, Ptr + 1 + 4
  Zone = Input(4, #1)
  ZoneHexa = BinToHexa(Zone)
  IndexLength = Hexa8ToBin(ZoneHexa)
 
  Seek #1, Ptr + 1 + 10
  Zone = Input(1, #1)
  ZoneHexa = BinToHexa(Zone)
  EntriesNumber = Val("&H" & ZoneHexa)
 
  Seek #1, Ptr + 1 + 12
  Zone = Input(EntriesNumber * 4, #1)
  ZoneHexa = BinToHexa(Zone)
  ZoneParamD = Zone
 
  Seek #1, (Ptr + 1) + 12 + EntriesNumber * 4
  L = IndexLength - EntriesNumber * 4
  ZoneParamI = Input(L, #1)
  ZoneHexa = BinToHexa(ZoneParamI)
  For i = 1 To 19
    EndTable(i) = L
  Next i
  i1 = 0
  For i = 1 To EntriesNumber
    ' récupération des indices relatifs des paramètres indirects
    ' les codes sont dans l'ordre croissant
    CodeText = BinToHexa(Mid$(ZoneParamD, ((i - 1) * 4) + 1, 1))
    V = Val("&H" & CodeText)
    If V < 20 Then '80
      Zone = Mid$(ZoneParamD, ((i - 1) * 4) + 2, 3)
      BeginTable(V) = Hexa6ToBin(BinToHexa(Zone))
      If V > 1 And i1 > 0 Then EndTable(i1) = BeginTable(V) - 1
      i1 = V
    End If
  Next i
 
  For i = 1 To EntriesNumber
    CodeText = BinToHexa(Mid$(ZoneParamD, ((i - 1) * 4) + 1, 1))
    V = Val("&H" & CodeText)
    Select Case V
        Case &H2
            L = Higher(EndTable(V) - BeginTable(V), 1)
            R.OEName = (Mid$(ZoneParamI, BeginTable(V) + 1, L))
        Case &H80
            R.RegInfo = BinToHexa(Mid(ZoneParamD, ((i - 1) * 4) + 2, 3))
        End Select
    Next i
 
    ReadIndexInfo = R
  Exit Function
ErrorTag:
  MsgBox "Incohérence de lecture de l'index : " & Ptr, vbCritical, "ReadIndexInfo"
End Function
Private Function ReadTreeHead(Ptr As Long) As TreeHeader_Record
Dim Zone As String, ZoneHexa As String
Dim R As TreeHeader_Record
  On Error GoTo ErrorTag
 
  Seek #1, Ptr + 1
  'recherche marqueur
  Zone = Input(4, #1)
  ZoneHexa = BinToHexa(Zone)
  If Hexa8ToBin(ZoneHexa) <> Ptr Then GoTo ErrorTag
 
  Seek #1, Ptr + &H8 + 1
  Zone = Input(4, #1) ' Noeud enfant
  ZoneHexa = BinToHexa(Zone)
  R.ChildNode = Hexa8ToBin(ZoneHexa)
  Seek #1, Ptr + &H11 + 1
  Zone = Input(1, #1)
  ZoneHexa = BinToHexa(Zone)
  R.EntriesNumber = Val("&H00" & ZoneHexa)
  ReadTreeHead = R
  Exit Function
ErrorTag:
  MsgBox "Incohérence de lecture du pointeur de l'arbre : " & Ptr, vbCritical, "ReadTreeHead"
End Function
Private Function ReadFoldersHead() As Long
Const SignOE5Dbx As String = "CFAD12FE"
Const SignOE5DbxFolder As String = "C6FD746F"
Const SignOE5DbxFin As String = "66E3D1119A4E00C04FA309D40500000005000000"
Dim i As Long, j As Long
Dim Zone As String, ZoneHexa As String, Ptr As String
  On Error GoTo ErrorTag
' vérifier le type de FilePath
  Seek #1, &H0 + 1
  Zone = Input(4, #1)
  ZoneHexa = BinToHexa(Zone)
  If ZoneHexa <> SignOE5Dbx Then GoTo ErrorTag
 
  ' Contrôler qu'il s'agit bien de Folders.dbx ?
  Seek #1, &H4 + 1
  Zone = Input(4, #1)
  ZoneHexa = BinToHexa(Zone)
  If ZoneHexa <> SignOE5DbxFolder Then GoTo ErrorTag
 
  ' pointeur vers le noeud d'origine de l'arborescence
  ' pointe vers tous les sous-dossiers de "Outlook Express"
  ' ce sont les dossiers visibles dans le panneau d'affichage des dossiers de OE
  Seek #1, &HEC + 1
  Zone = Input(4, #1)
  ZoneHexa = BinToHexa(Zone)
  RootPtr = Hexa8ToBin(ZoneHexa)
 
  ReadFoldersHead = RootPtr
 
  Exit Function
ErrorTag:
  'Resume Next
  ReadFoldersHead = 0 'F
End Function
'------------------------------------ Conversions
Private Function BinToHexa(S As String) As String
Dim ValAscii As Integer
Dim i As Long
Dim R As String
  ' Traduit un ensemble de caractères binaires en présentation hexadécimale
  R = ""
  For i = 1 To Len(S)
    ValAscii = Asc(Mid$(S, i, 1))
    R = R & Hex(Int(ValAscii / 16)) & Hex(ValAscii Mod 16)
  Next
  BinToHexa = R
End Function
Private Function Hexa6ToBin(S As String) As Long 'Hexa6ToBin
Dim L As Long, L1 As Long, L2 As Long
  ' calcule la valeur binaire d'une donnée sur 6 caractères en représentation Hexa
  L1 = Val("&H" & Mid$(S, 6, 1))
  L2 = Val("&H" & Mid$(S, 5, 1))
  If L2 < 8 Then 'pour Mid$(S, 5, 1), les valeurs B à F ne sont pas obtenues
    L = Val("&H" & Mid$(S, 5, 2))
  Else: L = -(L1 + 16 * (L2 - 8))
  End If
  L = L * 256 + Val("&H" & Mid$(S, 3, 2))
  Hexa6ToBin = L * 256 + Val("&H" & Mid$(S, 1, 2))
End Function
Private Function Hexa8ToBin(S As String) As Long 'Hexa8ToBin
Dim L As Long, L1 As Long, L2 As Long
  ' calcule la valeur binaire d'une donnée sur 8 caractères en représentation Hexa
  L1 = Val("&H" & Mid$(S, 8, 1))
  L2 = Val("&H" & Mid$(S, 7, 1))
  If L2 < 8 Then
    L = Val("&H" & Mid$(S, 7, 2)) 'S semble toujours finir par "00", donc cette valeur est nulle
  Else: L = -(L1 + 16 * (L2 - 8))
  End If
  L = L * 256 + Val("&H" & Mid$(S, 5, 2))
  L = L * 256 + Val("&H" & Mid$(S, 3, 2))
  Hexa8ToBin = L * 256 + Val("&H" & Mid$(S, 1, 2))
End Function
Private Function Higher(a As Integer, b As Integer) As Integer
  If a > b Then Higher = a Else Higher = b
End Function
'------------------------------------ Base de registre
Private Function OpenKey(sKeyName As String, hKey As Long) As Long
Dim RetVal As Long
  On Error GoTo Erreur
 
  'ouvrir la clef et détermination de son adresse
  RetVal = RegOpenKeyEx(HKEY_CURRENT_USER, sKeyName, 0, KEY_ALL_ACCESS, hKey)
  OpenKey = RetVal
 
  Exit Function
Erreur:
  'Resume Next
  MsgBox Error, , "OpenKey": End
End Function
Public Function GetKeyValue(hKey As Long, sValueName As String, sValue As String, Optional sKey As String = "")
'résultat de la fonction API
Dim RetVal As Long
Dim cch As Long, lType As Long
Dim S As String
  On Error GoTo SubError
 
  'déterminer la taille et le type de donnée à lire
  RetVal = RegQueryValueExNULL(hKey, sValueName, 0&, lType, 0&, cch)
  If RetVal <> ERROR_NONE Then GoTo SubError
  S = String$(cch, 0) 'initialisation avec des caractères "Null"
  RetVal = RegQueryValueExString(hKey, sValueName, 0&, lType, S, cch)
  If RetVal = ERROR_NONE Then sValue = Left$(S, cch - 1) Else sValue = Empty
 
GetKeyValueExit:
  GetKeyValue = RetVal
  Exit Function
SubError:
  If RetVal = 2 Then
    MsgBox "Identité introuvable"
    GoTo GetKeyValueExit
  Else
    MsgBox Error
    Resume GetKeyValueExit
  End If
End Function

Importer les fichiers d'un dossier Outlook Express

Macros et VBA Excel

Discussions similaires

Partager

Partager