Liste contenu répertoire Outlook

Bonjour

J'ai un petit script qui permet de liste les dossiers dans Outlook

Toutefois j'aimerais faire une boucle pour que ce soit non seulement le compte principal mais aussi tout les autres comptes "ajouté" au compte principal.

Finalement j'aimerais lister les comptes Outlook et les partagés et les dossiers qui sont sur le poste...

Une petite idée pour modifier mon script?

Code:

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
Dim MyFile, Structured, Base
 
Call ExportFolderNamesSelect()
 
Public Sub ExportFolderNamesSelect()
  Dim objOutlook
  Set objOutlook = CreateObject("Outlook.Application")
 
  Dim F, Folders
  Set F = objOutlook.Session.PickFolder
 
  If Not F Is Nothing Then
    Set Folders = F.Folders
 
    Dim Result
    Result = MsgBox("Do you want to structure the output?", vbYesNo+vbDefaultButton2+vbApplicationModal, "Output structuring")
    If Result = 6 Then
      Structured = True
    Else
      Structured = False
    End If
 
    MyFile = GetDesktopFolder() & "\outlookfolders.txt"
    Base = Len(F.FolderPath) - Len(Replace(F.FolderPath, "\", "")) + 1
 
    WriteToATextFile (StructuredFolderName(F.FolderPath, F.Name))
 
    LoopFolders Folders
 
    Set F = Nothing
    Set Folders = Nothing
    Set objOutlook = Nothing
  End If
End Sub
 
Private Function GetDesktopFolder()
  Dim objShell
  Set objShell = CreateObject("WScript.Shell")
  GetDesktopFolder = objShell.SpecialFolders("Desktop")
  Set objShell = Nothing
End Function
 
Private Sub LoopFolders(Folders)
  Dim F
 
  For Each F In Folders
    WriteToATextFile (StructuredFolderName(F.FolderPath, F.Name))
    LoopFolders F.Folders
  Next
End Sub
 
Private Sub WriteToATextFile(OLKfoldername)
  Dim objFSO, objTextFile
  Set objFSO = CreateObject("Scripting.FileSystemObject")
  Set objTextFile = objFSO.OpenTextFile (MyFile, 8, True)
  objTextFile.WriteLine (OLKfoldername)
  objTextFile.Close
  Set objFSO = Nothing
  Set objTextFile = Nothing
End Sub
 
Private Function StructuredFolderName(OLKfolderpath, OLKfoldername)
  If Structured = False Then
    StructuredFolderName = Mid(OLKfolderpath, 3)
  Else
    Dim i, x, OLKprefix
    i = Len(OLKfolderpath) - Len(Replace(OLKfolderpath, "\", ""))
 
    For x = Base To i
      OLKprefix = OLKprefix & "-"
    Next
 
    StructuredFolderName = OLKprefix & OLKfoldername
  End If
End Function