Zugriffsrechte von Ordnern mit VB-Script auslesen

    Option Explicit
    Option Compare Text
    
    Const FoldersPath = "D:\Temp"                           'Start-Ordner  
    
    Const CsvFileName = "FolderUserRights.csv"              'Wird im Workbook-Pfad gespeichert  
   
    Const CsvDelim = ";"                                    'Beliebiges Trennzeichen festlegen  
  '______________________________________________________________________________________  
    
   'Spalte 1-4 = Path, Erstellungsdatum, Gruppe/Benutzername, G/B-Name-SID  
    Const CsvTextReserved = 4
   
   'Control-Flag Infos verfügbar  
    Const SE_DACL_PRESENT = &H4
    
   'Zugriffs-Flags, TitelText nach belieben festlegen  
    Const AF00 = "AF&;&H01;TitelText"             'OBJECT_INHERIT_ACE  
    Const AF01 = "AF&;&H02;TitelText"             'CONTAINER_INHERIT_ACE  
    Const AF02 = "AF&;&H04;TitelText"             'NO_PROPOGATE_INHERIT_ACE  
    Const AF03 = "AF&;&H08;TitelText"             'INHERIT_ONLY_ACE  
    Const AF04 = "AF&;&H10;TitelText"             'INHERIT_ACE"  
    
   'Zugriffs-Type  
    Const ATx0 = "AT=;&H00;TitelText"             'ACCESS_ALLOWED_ACE_TYPE  
    
    Const AT00 = "AT&;&H01;TitelText"             'ACCESS_DENIED_ACE_TYPE  
    Const AT01 = "AT&;&H02;TitelText"             'AUDIT  
      
   'Zugriffsrechte: Objektspezifisch  
    Const AM00 = "AM&;&H00000001;TitelText"       'DIR_LIST_DIRECTORY/FILE_READ_DATA  
    Const AM01 = "AM&;&H00000002;TitelText"       'DIR_ADD_FILE/FILE_WRITE_DATA  
    Const AM02 = "AM&;&H00000004;TitelText"       'DIR_ADD_SUBDIRECTORY/FILE_APPEND_DATA  
    Const AM03 = "AM&;&H00000008;TitelText"       'READ_NAMED_ATTRIBUTS  
    Const AM04 = "AM&;&H00000010;TitelText"       'WRITE_NAMED_ATTRIBUTS  
    Const AM05 = "AM&;&H00000020;TitelText"       'EXECUTE  
    Const AM06 = "AM&;&H00000040;TitelText"       'DELETE_CHILD  
    Const AM07 = "AM&;&H00000080;TitelText"       'READ_ATTRIBUTES  
    Const AM08 = "AM&;&H00000100;TitelText"       'WRITE_ATTRIBUTES  
    
    Const AMx1 = "AM=;&H001F01FF;TitelText"       'FILE_ALL_ACCESS"  
    
    'Zugriffsrechte: Standard --> Zugriffsrechte auf Objektspezifisch  
    Const AM16 = "AM&;&H00010000;TitelText"       'DELETE  
    Const AM17 = "AM&;&H00020000;TitelText"       'READ_ACL  
    Const AM18 = "AM&;&H00040000;TitelText"       'WRITE_ACL  
    Const AM19 = "AM&;&H00080000;TitelText"       'WRITE_OWNER  
    Const AM20 = "AM&;&H00100000;TitelText"       'SYNCHRONIZE  
    
    'Zugriffsrechte: Security-Descriptor SACL (System Access Control List)  
    Const AM24 = "AM&;&H01000000;TitelText"       'ACCESS_SYSTEM_SECURITY  
    
    'Zugriffsrechte Erweitert --> Zugriffsrechte auf Standard/Objektspezifisch  
    Const AM28 = "AM&;&H10000000;TitelText"       'GENERIC_ALL  
    Const AM29 = "AM&;&H20000000;TitelText"       'GENERIC_EXECUTE  
    Const AM30 = "AM&;&H40000000;TitelText"       'GENERIC_WRITE  
    Const AM31 = "AM&;&H80000000;TitelText"       'GENERIC_READ  
'______________________________________________________________________________________  
    
    Const Msg0 = "Der Vorgang kann je nach Anzahl der Ordner einige Minuten dauern!"  
    Const Msg1 = "Der Csv-Export ist abgeschlossen."  
    
    Dim Fso As Object, ACL As Object, objWMIService As Object, CsvFile As Object
    Dim CsvText As Variant, CsvSize As Integer

Sub GetFoldersAccessRights()
    Dim CsvListe As Variant, CsvTitel As Variant, Token As Variant, i As Integer
    
    If MsgBox(Msg0, vbOKCancel Or vbInformation, "Zugriffsrechte...") = vbCancel Then Exit Sub  
    
    CsvListe = Array(AF00, AF01, AF02, AF03, AF04, ATx0, AT00, AT01, AM00, AM01, AM02, AM03, AM04, AM05, AM06, AM07, AM08, AM16, AM17, AM18, AM19, AM20, AMx1)

    CsvSize = UBound(CsvListe) + CsvTextReserved
    
    ReDim CsvText(CsvSize):  ReDim CsvTitel(CsvSize)
    
    Set ACL = CreateObject("Scripting.Dictionary")  
    
    CsvTitel(0) = "Pfad"  
    CsvTitel(1) = "Erstellt"  
    CsvTitel(2) = "Benutzer"  
    CsvTitel(3) = "SID"  
    
    For i = 0 To UBound(CsvListe)
        Token = Split(CsvListe(i), ";")  
        ACL.Add Token(0) & Hex(Token(1)), i + CsvTextReserved & ";" & Token(1)  
        CsvTitel(i + CsvTextReserved) = Token(2)
    Next

    Set Fso = CreateObject("Scripting.FileSystemObject")  
    Set objWMIService = GetObject("winmgmts:{impersonationLevel=Impersonate,(TakeOwnership)}!\\.\root\cimv2")  
    
    Set CsvFile = Fso.CreateTextFile(ThisWorkbook.Path & "\" & CsvFileName)  
    
    CsvFile.WriteLine Join(CsvTitel, ";")  
    
    Call GetFolder(Fso.GetFolder(FoldersPath)):   CsvFile.Close
    
    MsgBox Msg1, vbInformation, "Csv-Export..."  
End Sub

Private Sub GetFolder(ByRef Folder)
    Dim Subfolder As Object, i As Integer
    
    CsvText(0) = Folder.Path
    
    If Folder.Name = "" Then  
        CsvText(1) = ""  
    Else
        CsvText(1) = FormatDateTime(Folder.DateCreated, vbShortDate)
    End If
            
    Call GetSecuritySettings(Folder)
    
    On Error Resume Next
    
    For Each Subfolder In Folder.SubFolders
        If Err.Number = 0 Then
            Call GetFolder(Subfolder)
        Else
            Err.Clear
            Call WriteCsvFile("Zugriff verweigert")  
        End If
    Next
End Sub

Private Sub GetSecuritySettings(ByRef Folder)
    Dim objFSS As Object, objSD As Object, objACL As Variant
    Dim LastName As String, DoWrite As Boolean, i As Integer
    
    On Error Resume Next
    
    Set objFSS = objWMIService.Get("Win32_LogicalFileSecuritySetting='" & Folder & "'")  
    
    If Err.Number <> 0 Then
        Call WriteCsvFile("Nicht verfügbar"):  Exit Sub  
    End If
    
    On Error GoTo 0
    
    If objFSS.GetSecurityDescriptor(objSD) = 0 Then
        If (objSD.ControlFlags And SE_DACL_PRESENT) <> 0 Then
            For Each objACL In objSD.DACL
                With objACL
                    CsvText(2) = .Trustee.Name
                    CsvText(3) = .Trustee.SIDString
                        
                    For i = 4 To CsvSize:  CsvText(i) = "":  Next  
                    
                    Call SetSecuritySettings("AM", .AccessMask)  
                    Call SetSecuritySettings("AF", .AceFlags)  
                    Call SetSecuritySettings("AT", .AceType)  
                       
                    CsvFile.WriteLine Join(CsvText, CsvDelim)
                End With
            Next
        Else
            Call WriteCsvFile("Nicht verfügbar")  
        End If
    Else
        Call WriteCsvFile("Nicht verfügbar")  
    End If
End Sub

Private Sub SetSecuritySettings(ByRef Target, ByVal Value)
    Dim Key As Variant, Token As Variant
    
    If ACL.Exists(Target & "=" & Hex(Value)) Then  
        Token = Split(ACL.Item(Target & "=" & Hex(Value)), ";")  
        CsvText(Token(0)) = "x"  
    Else
        For Each Key In ACL.Keys
            If Left(Key, 3) = Target & "&" Then  
                Token = Split(ACL.Item(Key), ";")  
                If (Value And CLng(Token(1))) Then CsvText(Token(0)) = "x"  
            End If
        Next
    End If
End Sub

Private Sub WriteCsvFile(ByRef Text)
    Dim i As Integer

    CsvText(2) = Text
    
    For i = 3 To CsvSize:  CsvText(i) = "":  Next  
    
    CsvFile.WriteLine Join(CsvText, CsvDelim)
End Sub

    On Error Resume Next
    
    Set objFSS = objWMIService.Get("Win32_LogicalFileSecuritySetting='" & Folder & "'")  
    
    If Err.Number <> 0 Then MsgBox Folder
    
    On Error GoTo 0

       Option Explicit
    Option Compare Text
    
    Const FoldersPath = "C:\"       'Start-Ordner  
    
    Const SheetName = "Rechte1"     'Tabellenname wahlweise, am Ende muss die Ziffer 1 stehen  
    
    Const StartLine = 2             'Ab Zeile  
'______________________________________________________________________________________  
    
   'Spalte 1-4 = Path, Erstellungsdatum, Gruppe/Benutzername, G/B-Name-SID  
    Const TextReserved = 4
   
   'Control-Flag Infos verfügbar  
    Const SE_DACL_PRESENT = &H4
    
   'Zugriffs-Flags, TitelText nach belieben festlegen  
    Const AF00 = "AF&;&H01;TitelText"             'OBJECT_INHERIT_ACE  
    Const AF01 = "AF&;&H02;TitelText"             'CONTAINER_INHERIT_ACE  
    Const AF02 = "AF&;&H04;TitelText"             'NO_PROPOGATE_INHERIT_ACE  
    Const AF03 = "AF&;&H08;TitelText"             'INHERIT_ONLY_ACE  
    Const AF04 = "AF&;&H10;TitelText"             'INHERIT_ACE"  
    
   'Zugriffs-Type  
    Const ATx0 = "AT=;&H00;TitelText"             'ACCESS_ALLOWED_ACE_TYPE  
    
    Const AT00 = "AT&;&H01;TitelText"             'ACCESS_DENIED_ACE_TYPE  
    Const AT01 = "AT&;&H02;TitelText"             'AUDIT  
      
   'Zugriffsrechte: Objektspezifisch  
    Const AM00 = "AM&;&H00000001;TitelText"       'DIR_LIST_DIRECTORY/FILE_READ_DATA  
    Const AM01 = "AM&;&H00000002;TitelText"       'DIR_ADD_FILE/FILE_WRITE_DATA  
    Const AM02 = "AM&;&H00000004;TitelText"       'DIR_ADD_SUBDIRECTORY/FILE_APPEND_DATA  
    Const AM03 = "AM&;&H00000008;TitelText"       'READ_NAMED_ATTRIBUTS  
    Const AM04 = "AM&;&H00000010;TitelText"       'WRITE_NAMED_ATTRIBUTS  
    Const AM05 = "AM&;&H00000020;TitelText"       'EXECUTE  
    Const AM06 = "AM&;&H00000040;TitelText"       'DELETE_CHILD  
    Const AM07 = "AM&;&H00000080;TitelText"       'READ_ATTRIBUTES  
    Const AM08 = "AM&;&H00000100;TitelText"       'WRITE_ATTRIBUTES  
    
    Const AMx1 = "AM=;&H001F01FF;TitelText"       'FILE_ALL_ACCESS"  
    
    'Zugriffsrechte: Standard --> Zugriffsrechte auf Objektspezifisch  
    Const AM16 = "AM&;&H00010000;TitelText"       'DELETE  
    Const AM17 = "AM&;&H00020000;TitelText"       'READ_ACL  
    Const AM18 = "AM&;&H00040000;TitelText"       'WRITE_ACL  
    Const AM19 = "AM&;&H00080000;TitelText"       'WRITE_OWNER  
    Const AM20 = "AM&;&H00100000;TitelText"       'SYNCHRONIZE  
    
    'Zugriffsrechte: Security-Descriptor SACL (System Access Control List)  
    Const AM24 = "AM&;&H01000000;TitelText"       'ACCESS_SYSTEM_SECURITY  
    
    'Zugriffsrechte Erweitert --> Zugriffsrechte auf Standard/Objektspezifisch  
    Const AM28 = "AM&;&H10000000;TitelText"       'GENERIC_ALL  
    Const AM29 = "AM&;&H20000000;TitelText"       'GENERIC_EXECUTE  
    Const AM30 = "AM&;&H40000000;TitelText"       'GENERIC_WRITE  
    Const AM31 = "AM&;&H80000000;TitelText"       'GENERIC_READ  
'______________________________________________________________________________________  
    
    Const Msg0 = "Der Vorgang kann je nach Anzahl der Ordner einige Minuten dauern!"  
    Const Msg1 = "Das Einlesen der Rechte aus %1 Ordnern ist abgeschlossen."  
    
    Dim Fso As Object, ACL As Object, objWMIService As Object, TextLine As Variant, TitelLine As Variant
    Dim TextSize As Long, CellSize As Long, FoldersCount As Long, NewLine As Long, EndLine As Long

Sub GetFoldersAccessRights()
    Dim TextList As Variant, Token As Variant, i As Integer
    
    If MsgBox(Msg0, vbOKCancel Or vbInformation, "Zugriffsrechte...") = vbCancel Then Exit Sub  
    
    TextList = Array(AF00, AF01, AF02, AF03, AF04, ATx0, AT00, AT01, AM00, AM01, AM02, AM03, AM04, AM05, AM06, AM07, AM08, AM16, AM17, AM18, AM19, AM20, AMx1)

    TextSize = UBound(TextList) + TextReserved:  CellSize = TextSize + 1
    
    ReDim TextLine(TextSize):  ReDim TitelLine(TextSize)
    
    Set ACL = CreateObject("Scripting.Dictionary")  
    
    TitelLine(0) = "Pfad"  
    TitelLine(1) = "Erstellt"  
    TitelLine(2) = "Benutzer"  
    TitelLine(3) = "SID"  
    
    For i = 0 To UBound(TextList)
        Token = Split(TextList(i), ";")  
        ACL.Add Token(0) & Hex(Token(1)), i + TextReserved & ";" & Token(1)  
        TitelLine(i + TextReserved) = Token(2)
    Next

    Set Fso = CreateObject("Scripting.FileSystemObject")  
    Set objWMIService = GetObject("winmgmts:{impersonationLevel=Impersonate,(TakeOwnership)}!\\.\root\cimv2")  
    
    FoldersCount = 0
    
    Call CleanUpSheets
    
    Range(Range("A1"), Cells(1, CellSize)) = TitelLine  
    
    Call GetFolder(Fso.GetFolder(FoldersPath))
    
    MsgBox Replace(Msg1, "%1", FoldersCount), vbInformation, "Rechte einlesen..."  
End Sub

Private Sub GetFolder(ByRef Folder)
    Dim Subfolder As Object, i As Integer
    
    TextLine(0) = Folder.Path
    
    If Folder.Name = "" Then  
        TextLine(1) = ""  
    Else
        TextLine(1) = FormatDateTime(Folder.DateCreated, vbShortDate)
    End If
            
    Call GetSecuritySettings(Folder)
    
    On Error Resume Next
    
    For Each Subfolder In Folder.SubFolders
        If Err.Number = 0 Then
            Call GetFolder(Subfolder)
        Else
            Err.Clear
            Call WriteText("Zugriff verweigert")  
        End If
    Next
End Sub

Private Sub GetSecuritySettings(ByRef Folder)
    Dim objFSS As Object, objSD As Object, objACL As Variant
    Dim LastName As String, DoWrite As Boolean, i As Integer
    
    FoldersCount = FoldersCount + 1
    
    On Error Resume Next
    
    Set objFSS = objWMIService.Get("Win32_LogicalFileSecuritySetting='" & Folder & "'")  
    
    If Err.Number <> 0 Then
        Call WriteText("Nicht verfügbar"):  Exit Sub  
    End If
    
    On Error GoTo 0
    
    If objFSS.GetSecurityDescriptor(objSD) = 0 Then
        If (objSD.ControlFlags And SE_DACL_PRESENT) <> 0 Then
            For Each objACL In objSD.DACL
                With objACL
                    TextLine(2) = .Trustee.Name
                    TextLine(3) = .Trustee.SIDString
                        
                    For i = 4 To TextSize:  TextLine(i) = "":  Next  
                    
                    Call SetSecuritySettings("AM", .AccessMask)  
                    Call SetSecuritySettings("AF", .AceFlags)  
                    Call SetSecuritySettings("AT", .AceType)  
                       
                    If NewLine > EndLine Then Call CreateNewSheet
                    
                    Range(Cells(NewLine, 1), Cells(NewLine, CellSize)) = TextLine: NewLine = NewLine + 1
                End With
            Next
        Else
            Call WriteText("Nicht verfügbar")  
        End If
    Else
        Call WriteText("Nicht verfügbar")  
    End If
End Sub

Private Sub SetSecuritySettings(ByRef Target, ByVal Value)
    Dim Key As Variant, Token As Variant
    
    If ACL.Exists(Target & "=" & Hex(Value)) Then  
        Token = Split(ACL.Item(Target & "=" & Hex(Value)), ";")  
        TextLine(Token(0)) = "x"  
    Else
        For Each Key In ACL.Keys
            If Left(Key, 3) = Target & "&" Then  
                Token = Split(ACL.Item(Key), ";")  
                If (Value And CLng(Token(1))) Then TextLine(Token(0)) = "x"  
            End If
        Next
    End If
End Sub

Private Sub WriteText(ByRef Text)
    Dim i As Integer

    TextLine(2) = Text
    
    For i = 3 To TextSize:  TextLine(i) = "":  Next  
    
    If NewLine > EndLine Then Call CreateNewSheet
                    
    Range(Cells(NewLine, 1), Cells(NewLine, CellSize)) = TextLine: NewLine = NewLine + 1
End Sub

Private Sub CleanUpSheets()
    Dim Wks As Worksheet
    
    ThisWorkbook.Activate
    
    Sheets(SheetName).Cells.Clear
    
    For Each Wks In Sheets
        If Wks.Name Like Left(SheetName, Len(SheetName) - 1) & "[!1]" Then  
            Application.DisplayAlerts = False
            Wks.Delete
            Application.DisplayAlerts = True
        End If
    Next
    Sheets(SheetName).Activate:  Range("A1").Select  
    
    NewLine = StartLine:  EndLine = Rows.Count
End Sub

Private Sub CreateNewSheet()
    Dim LastNumber As Integer, LastName As String
    
    LastName = ActiveSheet.Name
    LastNumber = Right(LastName, 1)
    
    Sheets.Add After:=ActiveSheet
    
    ActiveSheet.Name = Replace(LastName, LastNumber, LastNumber + 1)
    
    Range(Range("A1"), Cells(1, CellSize)) = TitelLine  
    
    NewLine = StartLine
End Sub