Discussion :

[DPhBxl]

La question est simple, mais je pense que la réponse ne l'est pas.
Je cherche à connaître la liste des utilisateurs ayant des droits sur une boîte/sous-répertoires et le type de droits.
Exemple :
Mr.X - Propriétaire(Owner)
Mr.Y - Editeur
...

Mr.Z - Peut créer des répertoires et lire les mails.
Mr.T - Ne peut que lire les mails.
...

En fait, cette énumération se fait via les autorisations d'accès sur la racine ou dans chaque répertoire. Mais ici, j'ai plus de 1000 sous-répertoires !!!
J'aimerai pouvoir en faire une liste dans Excel.

[Oliv-]

Bonjour,

voici de quoi commencer, IL FAUT INSTALLER REDEMPTION
--> http://www.dimastr.com/redemption/download.htm

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
Option Explicit
'---------------------------------------------------------------------------------------
' Procedure : EnumerateFolderACL
' Author    : octu
' Date      : 15/11/2018
' Purpose   :
'---------------------------------------------------------------------------------------
'
Sub EnumerateFolderACL()
    Dim ParentFolder As Object
    Dim RDOSession As Object
    Dim lblParentfolder
 
    On Error Resume Next
    Set RDOSession = CreateObject("Redemption.RDOSession")
    If RDOSession Is Nothing Then
        MsgBox "Vous devez avoir REDEMPTION sur le poste" & vbCr & "http://www.dimastr.com/redemption/download.htm"
        Exit Sub
    ElseIf Majversion("5.8.0.4036", RDOSession.Version) Then
        MsgBox "Votre version de REDEMPTION " & vbCr & RDOSession.Version & vbCr & "n'est pas compatible" & vbCr & "http://www.dimastr.com/redemption/download.htm"
        Exit Sub
    End If
    On Error GoTo 0
    RDOSession.MAPIOBJECT = Application.GetNamespace("MAPI").MAPIOBJECT
    'RDOSession = Application.Session
    'RDOSession.Logon
 
 
    Set ParentFolder = RDOSession.GetDefaultFolder(olFolderInbox)    '.Parent
    On Error Resume Next
    Set ParentFolder = RDOSession.GetFolderFromID(Application.GetNamespace("MAPI").PickFolder.EntryID)
    If ParentFolder Is Nothing Then Exit Sub
    On Error GoTo 0
    lblParentfolder = ParentFolder.Name
    If lblParentfolder = "IPM_SUBTREE" Then lblParentfolder = Replace(ParentFolder.FolderPath, "\\", "")
 
    Call EnumerateFolder_acl(RDOSession, ParentFolder)
 
End Sub
 
Sub EnumerateFolder_acl(RDOSession As Object, StartFolder As Object)  'Outlook.MAPIFolder)
 
    Dim FilleFolder As Object
    Dim FilleACES As Object
    Dim FilleACE As Object
    Dim ParentACE As Object
    Dim AddressEntry As Object
    Dim ACE As Object
 
    Debug.Print "### " & StartFolder.Name & " ###"
 
    For Each ParentACE In StartFolder.ACL
        'MsgBox StartFolder.Name & vbCr & ParentACE.Name & " - " & ParentACE.Rights
        Debug.Print StartFolder.Name & "|" & ParentACE.Name & " - " & ParentACE.Rights
    Next ParentACE
 
 
suite:
    ' Parcourt tous les sous-dossiers de ce dossier
    For Each FilleFolder In StartFolder.Folders
        Call EnumerateFolder_acl(RDOSession, FilleFolder)
    Next
 
End Sub
 
 
 
Function Majversion(LocalVersion As String, ServeurVersion As String) As Boolean
    Dim ServeurVersionDetail, ClientVersionDetail
    Majversion = False
    If ServeurVersion = LocalVersion Then Exit Function
    On Error GoTo 0
    ServeurVersionDetail = Split(ServeurVersion, ".", , vbTextCompare)
    ClientVersionDetail = Split(LocalVersion, ".", , vbTextCompare)
 
    If ServeurVersionDetail(0) > ClientVersionDetail(0) Then
        Majversion = True
    ElseIf ServeurVersionDetail(0) = ClientVersionDetail(0) And ServeurVersionDetail(1) > ClientVersionDetail(1) Then
        Majversion = True
    ElseIf ServeurVersionDetail(1) = ClientVersionDetail(1) And ServeurVersionDetail(0) = ClientVersionDetail(0) And CInt(ServeurVersionDetail(2) & ServeurVersionDetail(3)) > CInt(ClientVersionDetail(2)) Then
        Majversion = True
    Else: Majversion = False
 
    End If
fin:
End Function

RIGHTS_EDIT_OWN = &H00000008
RIGHTS_EDIT_ALL = &H00000020
RIGHTS_DELETE_OWN = &H00000010
RIGHTS_DELETE_ALL = &H00000040
RIGHTS_READ_ITEMS = &H00000001
RIGHTS_CREATE_ITEMS = &H00000002
RIGHTS_CREATE_SUBFOLDERS = &H00000080
RIGHTS_FOLDER_OWNER = &H00000100
RIGHTS_FOLDER_CONTACT = &H00000200
RIGHTS_FOLDER_VISIBLE = &H00000400
RIGHTS_NONE = &H00000000
RIGHTS_ALL = &H000005FB

RIGHTS_FREEBUSY_DETAILED = &H00001000 (Outlook 2007 / Exchange 2007 specific)
RIGHTS_FREEBUSY_SIMPLE = &H00000800 (Outlook 2007 / Exchange 2007 specific)
ROLE_OWNER = &H000007FB
ROLE_PUBLISH_EDITOR = &H000004FB
ROLE_EDITOR = &H0000047B
ROLE_PUBLISH_AUTHOR = &H0000049B
ROLE_AUTHOR = &H0000041B
ROLE_NONEDITING_AUTHOR = &H00000413
ROLE_REVIEWER = &H00000401
ROLE_CONTRIBUTOR = &H00000402
ROLE_NONE = &H00000400

[DPhBxl]

Je n'ai qu'un mot à la bouche ... FORMIDABLE