VBA Propriétés sécurité d'un dossier Windows

Le 31/08/2022 à 16:18

Bonjour,

Afin de préparer la migration d'un serveur windows vers un autre je souhaiterai créer une macro VBA afin de récupérer les propriétés de sécurité de certains répertoires ou fichiers.

En particulier :

image

J'ai quelques pistes comme "GetfileObjects" mais pas d'exemple précis

Merci pour vos réponses.

MetgeJP

Le 31/08/2022 à 20:32

Bonjour,

ci-dessous proposition de ce module :

Sub afficher_permissions(nom_objet)
    'ADsSecurityUtility" --> c:\windows\system32\activeds.dll
    Dim SDC As Object, liste_accès As Object, accès As Object
    Dim permissions As Object
    Dim tb(), i As Integer, clé
    Dim cell_tb As Range

    Const FILE_ALL_ACCESS = &H1F01FF
    Const FILE_APPEND_DATA = &H4
    Const FILE_DELETE = &H10000
    Const FILE_DELETE_CHILD = &H40
    Const FILE_EXECUTE = &H20
    Const FILE_READ_ATTRIBUTES = &H80
    Const FILE_READ_CONTROL = &H20000
    Const FILE_READ_DATA = &H1
    Const FILE_READ_EA = &H8
    Const FILE_SYNCHRONIZE = &H100000
    Const FILE_WRITE_ATTRIBUTES = &H100
    Const FILE_WRITE_DAC = &H40000
    Const FILE_WRITE_DATA = &H2
    Const FILE_WRITE_EA = &H10
    Const FILE_WRITE_OWNER = &H80000

    '// Accès aux permissions du répertoire ou du fichier demandé
    Set SDC = CreateObject("ADsSecurityUtility").GetSecurityDescriptor(nom_objet, 1, 1)
    Set permissions = CreateObject("Scripting.Dictionary")

    permissions("propriétaire") = Array(SDC.owner)

    Set liste_accès = SDC.DiscretionaryAcl
    For Each accès In liste_accès
        tb = Array(): i = 0

        ' Type d'accès
        If accès.AceType = &H0 Then ReDim Preserve tb(i): tb(i) = "Accès Autorisé": i = i + 1
        If accès.AceType = &H1 Then ReDim Preserve tb(i): tb(i) = "Accès Refusé": i = i + 1

        ' Détails des autorisations ou des refus
        If accès.AccessMask And FILE_ALL_ACCESS Then ReDim Preserve tb(i): tb(i) = "Contrôle total": i = i + 1
        If accès.AccessMask And FILE_APPEND_DATA Then ReDim Preserve tb(i): tb(i) = "Création de dossier / Ajout de données": i = i + 1
        If accès.AccessMask And FILE_DELETE Then ReDim Preserve tb(i): tb(i) = "Suppression": i = i + 1
        If accès.AccessMask And FILE_DELETE_CHILD Then ReDim Preserve tb(i): tb(i) = "Suppression de sous-dossier & fichier": i = i + 1
        If accès.AccessMask And FILE_EXECUTE Then ReDim Preserve tb(i): tb(i) = "Parcours du dossier / éxécuter le fichier": i = i + 1
        If accès.AccessMask And FILE_READ_ATTRIBUTES Then ReDim Preserve tb(i): tb(i) = "Attributs de lecture": i = i + 1
        If accès.AccessMask And FILE_READ_CONTROL Then ReDim Preserve tb(i): tb(i) = "Autorisation de lecture": i = i + 1
        If accès.AccessMask And FILE_READ_DATA Then ReDim Preserve tb(i): tb(i) = "Liste du dossier / lecture de données": i = i + 1
        If accès.AccessMask And FILE_READ_EA Then ReDim Preserve tb(i): tb(i) = "Lecture des attributs étendus": i = i + 1
        If accès.AccessMask And FILE_SYNCHRONIZE Then ReDim Preserve tb(i): tb(i) = "Synchronisation": i = i + 1
        If accès.AccessMask And FILE_WRITE_ATTRIBUTES Then ReDim Preserve tb(i): tb(i) = "Attributs d'ecriture": i = i + 1
        If accès.AccessMask And FILE_WRITE_DAC Then ReDim Preserve tb(i): tb(i) = "Modification des tb": i = i + 1
        If accès.AccessMask And FILE_WRITE_DATA Then ReDim Preserve tb(i): tb(i) = "Création de Fichier / écriture de données": i = i + 1
        If accès.AccessMask And FILE_WRITE_EA Then ReDim Preserve tb(i): tb(i) = "Ecriture d'attributs étendus": i = i + 1
        If accès.AccessMask And FILE_WRITE_OWNER Then ReDim Preserve tb(i): tb(i) = "Appropriation": i = i + 1

        If i > 1 Then permissions(accès.Trustee) = tb
    Next accès

    '// affichage permissions du répertoire ou du fichier dans la feuille active
    i = 0
    Set cell_tb = ActiveSheet.Columns("A").Find(""): If cell_tb Is Nothing Then Set cell_tb = ActiveSheet.Range("A1")
    cell_tb = "****************": Set cell_tb = cell_tb.Offset(1) 'on passe une ligne
    cell_tb = nom_objet: Set cell_tb = cell_tb.Offset(1) 'on passe une ligne

    For Each clé In permissions
        tb = permissions(clé)
        cell_tb.Offset(i) = clé
        cell_tb.Offset(i,1).Resize(, UBound(tb) + 1).Value = tb
        i = i + 1
    Next clé

End Sub
Le 01/09/2022 à 15:33

Bonjour Thev et Merci !!!

C'est exactement ce que je recherchais.

Sans abuser, peux-tu me rappeler (c'est ancien pour moi) comment intégrer dans mon programme appelant la sélection d'un dossier ou fichier dans l'explorateur ?

Cordialement,

Jean-Paul

Le 01/09/2022 à 16:18

Désolé de t'avoir sollicité à nouveau mais j'ai retrouvé la fonction.

Dernière question si ut le permets :

Peut-on adapter ta macro pour avoir une action récursive à partir d'un répertoire et de ses répertoires ?

Merci d'avance

JPM

Le 01/09/2022 à 17:36

Bonjour,

ci-dessous code demandé :

Sub liste_permissions()

    Dim nom_fichier As String, nom_fichier_complet As String, répertoire
    Dim Fso As Object, dossier_départ As Object

    '// création objet FilesSystem
    Set Fso = CreateObject("Scripting.FilesystemObject")

    '// Choix du répertoire de départ
    répertoire = Empty
    choix_répertoire répertoire
    If répertoire = Empty Then Exit Sub

    '// recherche des fichiers
    Set dossier_départ = Fso.GetFolder(répertoire)
    afficher_permissions répertoire
    rech_fichier Fso, dossier_départ

    '// libération objet FilesSystem
    Set Fso = Nothing

End Sub

Sub choix_répertoire(répertoire)
    Dim dossier As Object, item As Object

    Set dossier = CreateObject("shell.application").BrowseForFolder(0, "Choisir votre répertoire de départ", 0, "Bureau")
    If dossier Is Nothing Then MsgBox "aucun répertoire choisi": Exit Sub
    For Each item In dossier.ParentFolder.items
        If item.Name = dossier.Title Then répertoire = item.Path: Exit For
    Next item

End Sub

Sub rech_fichier(Fso As Object, dossier As Object)
    Dim sous_dossier As Object, fichier As Object
    Dim nom As String, extension_fichier As String

    '// recherche fichiers
    For Each fichier In dossier.Files
        afficher_permissions fichier.Path
    Next fichier

    '// recherche sous-dossier
    For Each sous_dossier In dossier.SubFolders
        afficher_permissions sous_dossier.Path
        If sous_dossier.Attributes <> vbDirectory + vbSystem + vbHidden Then rech_fichier Fso, sous_dossier
    Next
Le 01/09/2022 à 23:33

Bonsoir,

ci-dessous ajustement du module pour mieux coller à l'affichage de l'onglet sécurité

Sub afficher_permissions(nom_objet)
    'ADsSecurityUtility" --> c:\windows\system32\activeds.dll
    Dim SDC As Object, liste_accès As Object, accès As Object
    Dim permissions As Object
    Dim tb(), i As Integer, clé
    Dim cell_tb As Range

    Const FILE_ALL_ACCESS = &H1F01FF
    Const FILE_APPEND_DATA = &H4
    Const FILE_DELETE = &H10000
    Const FILE_DELETE_CHILD = &H40
    Const FILE_EXECUTE = &H20
    Const FILE_READ_ATTRIBUTES = &H80
    Const FILE_READ_CONTROL = &H20000
    Const FILE_READ_DATA = &H1
    Const FILE_READ_EA = &H8
    Const FILE_SYNCHRONIZE = &H100000
    Const FILE_WRITE_ATTRIBUTES = &H100
    Const FILE_WRITE_DAC = &H40000
    Const FILE_WRITE_DATA = &H2
    Const FILE_WRITE_EA = &H10
    Const FILE_WRITE_OWNER = &H80000

    '// Accès aux permissions du répertoire ou du fichier demandé
    Set SDC = CreateObject("ADsSecurityUtility").GetSecurityDescriptor(nom_objet, 1, 1)
    Set permissions = CreateObject("Scripting.Dictionary")

    permissions("propriétaire") = Array(SDC.owner)

    Set liste_accès = SDC.DiscretionaryAcl
    For Each accès In liste_accès
        tb = Array(): i = 0

        ' Type d'accès
        If accès.AceType = &H0 Then ReDim Preserve tb(i): tb(i) = "Accès Autorisé": i = i + 1
        If accès.AceType = &H1 Then ReDim Preserve tb(i): tb(i) = "Accès Refusé": i = i + 1

        ' Détails des autorisations ou des refus
        If accès.AccessMask = FILE_ALL_ACCESS Then
            ReDim Preserve tb(i): tb(i) = "Contrôle total": i = i + 1
        Else
            If accès.AccessMask And FILE_DELETE Then ReDim Preserve tb(i): tb(i) = "modification": i = i + 1
            If accès.AccessMask And FILE_EXECUTE Then ReDim Preserve tb(i): tb(i) = "lecture + exécution": i = i + 1
            If accès.AccessMask And FILE_READ_DATA Then ReDim Preserve tb(i): tb(i) = "affichage du dossier": i = i + 1
            If accès.AccessMask And FILE_READ_CONTROL Then ReDim Preserve tb(i): tb(i) = "lecture": i = i + 1
            If accès.AccessMask And FILE_WRITE_DATA Then ReDim Preserve tb(i): tb(i) = "écriture": i = i + 1
            If accès.AccessMask And FILE_WRITE_DAC Then ReDim Preserve tb(i): tb(i) = "modification de la sécurité": i = i + 1
            If accès.AccessMask And FILE_WRITE_OWNER Then ReDim Preserve tb(i): tb(i) = "modification du propriétaire": i = i + 1
        End If

        If Not permissions.exists(accès.Trustee) Then permissions(accès.Trustee) = tb
    Next accès

    '// affichage permissions du répertoire ou du fichier dans la feuille active
    i = 0
    Set cell_tb = ActiveSheet.Columns("A").Find(""): If cell_tb Is Nothing Then Set cell_tb = ActiveSheet.Range("A1")
    cell_tb = "****************": Set cell_tb = cell_tb.Offset(1) 'on passe une ligne
    cell_tb = nom_objet: Set cell_tb = cell_tb.Offset(1) 'on passe une ligne

    For Each clé In permissions
        tb = permissions(clé)
        cell_tb.Offset(i) = clé
        cell_tb.Offset(i, 1).Resize(, UBound(tb) + 1).Value = tb
        i = i + 1
    Next clé

End Sub
Le 02/09/2022 à 08:50

Bonjour thev et encore merci, c'est parfait !

Je vais maintenant m'atteler à la dure tâche de préparer ma migration !

Bonne journée et peut-être à plus ?

Amicalement

Jean-Paul

Le 06/09/2022 à 16:42

Bonjour Thev,

J'ai un autre besoin lié aux sujets précédents :

Est-il possible en VBA de faire une extraction d'un dossier comme avec Explorer :

Par exemple :

image

Merci pour ton aide une nouvelle fois

Cdlt

JPM

Le 06/09/2022 à 19:10

Bonjour,

Je peux te proposer ce formulaire affichant l'arborescence d'un dossier et permettant sa sauvegarde sur la feuille active du classeur :

19treeview-dossiers.xlsm (28.73 Ko)
Le 13/09/2022 à 20:15

Rebonjour Thev,

Voici un nouveau sujet : je souhaite établir un cockpit de suivi de projets avec des indicateurs de type tricolore.

Un exemple sera plus parlant, je te joins donc mon fichier en format draft pour le moment.

Merci d'avance

Amicalement

Jean-Paul

10new-cockpit-bb.xlsb (81.74 Ko)
Le 13/09/2022 à 21:43
Voici un nouveau sujet : je souhaite établir un cockpit de suivi de projets avec des indicateurs de type tricolore.
Nouveau sujet : vous devez le créer car vous ne pouvez rester dans celui-ci qui est d'ailleurs fermé.
Rechercher des sujets similaires à "vba proprietes securite dossier windows"