' ------------------------------------------------------------------------- ' ' ACLReport v1.01 ' Script by Sakari Kouti (see http://www.kouti.com and ' http://www.sovelto.fi) ' ' ------------------------------------------------------------------------- Option Explicit Dim strWelcome strWelcome = _ "This script dumps ACLs of Active Directory objects," & vbCrLf & _ "starting from a given root object (by default, the" & vbCrLf & _ "root of the default domain) into an HTML file called" & vbCrLf & _ "ACLReport.htm." & vbCrLf & _ "" & vbCrLf & _ "Best performance is achieved, when run locally on a DC." & vbCrLf & _ "" & vbCrLf & _ "Do you want to continue (and specify the root)?" ' ------------------------------------------------------------------------- ' ' IF YOU MODIFY THIS SCRIPT FOR INTERNAL USE, PLACE HERE A STATEMENT OF ' THE MODIFICATION ' ' ------------------------------------------------------------------------- ' ' Copyright Notice ' ' You have a royalty-free right to use and distribute the unmodified ' version of this script, provided that you agree that Addison-Wesley or ' Sakari Kouti has no warranty, obligations or liability for the script. ' ' You may also modify the script for the internal use in your organization, ' with the following three limitations: a) you may not modify or remove ' this copyright notice, b) you may not modify or remove the lines that ' generate to the HTML file the script name, the name of Sakari Kouti, and ' the two Web addresses, and c) you may not modify or remove the lines ' that generate the first message box in the script. ' Dim strTitleBar strTitleBar = "ACLReport v1.01 by Sakari Kouti" ' ' ------------------------------------------------------------------------- ' ' Version History ' ' Changes in v1.01 ' - Moved the welcome text to the beginning, so if you open the script ' in an editor, you see it right away ' - Added the search scope as a behavior constant, so you can easily ' modify it ' - Moved the LDAP filter definitions right after the actual behavior ' constants, so you can more easily modify the filters (if needed) ' - Added the explanation of white background to the color legend ' - Added a color background to the header row ' - Fixed the correct vbs name to the end of the HTML output ' - SCOPE_OUS_ONLY now includes also the domain object ' - Modified (most of) the progress messages to be displayed only if run ' in CScript ' ' ------------------------------------------------------------------------- '============================== 'Behavior constants 'You can modify these at will '============================== Const SCOPE_OUS_ONLY = True 'Whether to scan only OUs (and the domain object) or also other object classes Const SCOPE_NON_ADVANCED_VIEW = True 'Whether to scan only normal-view objects or also advanced-view objects Const SCOPE_ALL_ACES = True 'Whether to display all ACEs or only non-inherited Const SCOPE_STRING = "subTree" 'Either subTree, oneLevel, or base Dim strLDAPFilter If SCOPE_OUS_ONLY Then If SCOPE_NON_ADVANCED_VIEW Then strLDAPFilter = "(&(|(objectCategory=organizationalUnit)(objectCategory=domainDNS))(!showInAdvancedViewOnly=TRUE))" Else strLDAPFilter = "(|(objectCategory=organizationalUnit)(objectCategory=domainDNS))" End If Else If SCOPE_NON_ADVANCED_VIEW Then strLDAPFilter = "(!showInAdvancedViewOnly=TRUE)" Else strLDAPFilter = "(objectClass=*)" End If End If '============================== 'Script-level constants '============================== Const ADS_SCOPE_SUBTREE = 2 Const YES = "Yes" Const NBSP = " " '============================== 'Script-level variables '============================== '(and their initial values, 'if they act like constants) '============================== 'AccessMask Bits 'Constants would be like ADS_RIGHT_DS_CREATE_CHILD Dim arrADSRights(18,1) '19 value pairs, name and bit in each arrADSRights(0,0) = "Create Child(s)" 'DS_CREATE_CHILD arrADSRights(0,1) = &H1 arrADSRights(1,0) = "Delete Child(s)" 'DS_DELETE_CHILD arrADSRights(1,1) = &H2 arrADSRights(2,0) = "List Contents" 'ACTRL_DS_LIST arrADSRights(2,1) = &H4 arrADSRights(3,0) = "Validated Write(s)" 'DS_SELF" arrADSRights(3,1) = &H8 arrADSRights(4,0) = "Read Prop(s)" 'DS_READ_PROP arrADSRights(4,1) = &H10 arrADSRights(5,0) = "Write Prop(s)" 'DS_WRITE_PROP arrADSRights(5,1) = &H20 arrADSRights(6,0) = "Delete Subtree" 'DS_DELETE_TREE arrADSRights(6,1) = &H40 arrADSRights(7,0) = "List Object" 'DS_LIST_OBJECT arrADSRights(7,1) = &H80 arrADSRights(8,0) = "Extended Right(s)" 'DS_CONTROL_ACCESS arrADSRights(8,1) = &H100 arrADSRights(9,0) = "Delete" 'DELETE arrADSRights(9,1) = &H10000 arrADSRights(10,0) = "Read Permissions" 'READ_CONTROL arrADSRights(10,1) = &H20000 arrADSRights(11,0) = "Modify Permissions" 'WRITE_DAC arrADSRights(11,1) = &H40000 arrADSRights(12,0) = "Modify Owner" 'WRITE_OWNER arrADSRights(12,1) = &H80000 arrADSRights(13,0) = "SYNCHRONIZE" arrADSRights(13,1) = &H100000 arrADSRights(14,0) = "ACCESS_SYSTEM_SECURITY" arrADSRights(14,1) = &H1000000 arrADSRights(15,0) = "GENERIC_ALL" arrADSRights(15,1) = &H10000000 arrADSRights(16,0) = "GENERIC_EXECUTE" arrADSRights(16,1) = &H20000000 arrADSRights(17,0) = "GENERIC_WRITE" arrADSRights(17,1) = &H40000000 arrADSRights(18,0) = "GENERIC_READ" arrADSRights(18,1) = &H80000000 'AccessMask Combinations Dim arrADSRightCombinations(3,1) '19 value pairs, name and bit in each arrADSRightCombinations(0,0) = "Full Control" arrADSRightCombinations(0,1) = &HF01FF arrADSRightCombinations(1,0) = "Read (incl. List Obj.)" arrADSRightCombinations(1,1) = &H20094 arrADSRightCombinations(2,0) = "Read (excl. List Obj.)" arrADSRightCombinations(2,1) = &H20014 arrADSRightCombinations(3,0) = "Full Control except Delete Child(s) and Delete Subtree" arrADSRightCombinations(3,1) = &HF01BD 'AceFlags Bits 'Constants would be like ADS_ACEFLAG_INHERIT_ACE Dim arrADSACEFlags(5,1) '6 value pairs, name and bit in each arrADSACEFlags(0,0) = "INHERIT_ACE" arrADSACEFlags(0,1) = &H2 arrADSACEFlags(1,0) = "NO_PROPAGATE_INHERIT_ACE" arrADSACEFlags(1,1) = &H4 arrADSACEFlags(2,0) = "INHERIT_ONLY_ACE" arrADSACEFlags(2,1) = &H8 arrADSACEFlags(3,0) = "INHERITED_ACE" arrADSACEFlags(3,1) = &H10 arrADSACEFlags(4,0) = "SUCCESSFUL_ACCESS" arrADSACEFlags(4,1) = &H40 arrADSACEFlags(5,0) = "FAILED_ACCESS" arrADSACEFlags(5,1) = &H80 'AceTypes 'Constants would be like ADS_ACETYPE_ACCESS_ALLOWED Dim arrADSACETypes(5,1) '6 value pairs, name and value in each arrADSACETypes(0,0) = "Allow" 'ACCESS_ALLOWED" arrADSACETypes(0,1) = 0 arrADSACETypes(1,0) = "Deny" 'ACCESS_DENIED" arrADSACETypes(1,1) = &H1 arrADSACETypes(2,0) = "Audit" 'SYSTEM_AUDIT" arrADSACETypes(2,1) = &H2 arrADSACETypes(3,0) = "Allow (Object)" 'ACCESS_ALLOWED_OBJECT" arrADSACETypes(3,1) = &H5 arrADSACETypes(4,0) = "Deny (Object)" 'ACCESS_DENIED_OBJECT" arrADSACETypes(4,1) = &H6 arrADSACETypes(5,0) = "Audit (Object)" 'SYSTEM_AUDIT_OBJECT" arrADSACETypes(5,1) = &H7 'Flags Bits 'Constants would be like ADS_FLAG_OBJECT_TYPE_PRESENT Dim arrADSFlags(1,1) '2 value pairs, name and bit in each arrADSFlags(0,0) = "OBJECT_TYPE_PRESENT" arrADSFlags(0,1) = &H1 arrADSFlags(1,0) = "INHERITED_OBJECT_TYPE_PRESENT" arrADSFlags(1,1) = &H2 Dim strTColSep ', strTRowSep Dim strHTMLStart, strHTMLEnd, strTableStart, strTableEnd, strTRowEnd Dim strTHeaderRowStart Dim strTNormalRowStart Dim strTInheritedRowStart Dim strTDenyRowStart Dim strTInheritedDenyRowStart strHTMLStart = _ "ACLs of Objects" & vbCrLf & _ "" & vbCrLf & _ "" & vbCrLf strTableStart = "" & vbCrLf strTHeaderRowStart = "" & vbCrLf strTableEnd = _ "
" 'light turquoise strTNormalRowStart = "
" 'white strTInheritedRowStart = "
" 'silver strTDenyRowStart = "
" 'pinkish red strTInheritedDenyRowStart = "
" 'dim red strTColSep = "" strTRowEnd = _ "
" & vbCrLf strHTMLEnd = _ "

" & vbCrLf & _ "

To better examine the results:
" & vbCrLf & _ "1. Right-click the table in IE and select Export to Microsoft Excel.
" & vbCrLf & _ "2. In Excel's Data menu, select Filter => AutoFilter.
" & vbCrLf & _ "3. Use the drop-down lists on the header row to see the selection of values
" & vbCrLf & _ "    or to filter rows.
" & vbCrLf & _ "4. Click cell B2.
" & vbCrLf & _ "5. In Excel's Window menu, select Freeze Panes.

" & vbCrLf & _ "

Tip

" & vbCrLf & _ "

Every now and then, use this script to take a snapshot of the permissions
" & vbCrLf & _ "in your domain. By comparing the snapshots, you can track any changes to the
" & vbCrLf & _ "permissions.

" & vbCrLf & _ "

Color Legend

" & vbCrLf & _ "" & vbCrLf & _ "" & vbCrLf & _ "" & vbCrLf & _ "" & vbCrLf & _ "" & vbCrLf & _ "
An Allow ACE that is non-inherited
An Allow ACE that is inherited
A Deny ACE that is non-inherited
A Deny ACE that is inherited
" & vbCrLf & _ "

This table was generated at " & Now() & " by ACLReport.vbs,
" & vbCrLf & _ "a script by Sakari Kouti (see http://www.kouti.com and http://www.sovelto.fi)

" & vbCrLf & _ "" & vbCrLf Dim objDSE, strDefaultDN, objADObject, i Dim objSecDesc, objDACL, objACE Dim objConnection, objCommand, objRecordset Dim strRootDN Dim intYesNo Dim objFSO, objOutfile Dim dicSchemaIDGUIDs, dicRightsGuids Dim bolCScript '============================== 'The Main Program '============================== Call CheckWSHEnvironment(bolCScript) If bolCScript Then WScript.Echo strTitleBar intYesNo = MsgBox(strWelcome, _ vbYesNo + vbQuestion + vbDefaultButton2, _ strTitleBar) If intYesNo = vbNo Then If bolCScript Then WScript.Echo "Exited by user request" WScript.Quit(0) 'no error so no errorlevel End If '------------------------------ ' Ask the Root Object '------------------------------ Set objDSE = GetObject("LDAP://rootDSE") strDefaultDN = objDSE.Get("defaultNamingContext") strRootDN = InputBox("Enter the distinguished name of the root object" & _ vbCrLf & "(e.g. " & strDefaultDN & ")", , strDefaultDN) If strRootDN = "" Then WScript.Quit(1) 'user clicked Cancel '------------------------------ ' ADO init '------------------------------ Set objConnection = CreateObject("ADODB.Connection") objConnection.Provider = "ADsDSOObject" objConnection.Open Set objCommand = CreateObject("ADODB.Command") Set objCommand.ActiveConnection = objConnection Set objFSO = CreateObject("Scripting.FileSystemObject") Set objOutfile = objFSO.CreateTextFile("ACLReport.htm", True) Call objOutfile.Write(strHTMLStart & strTableStart) Call WriteHeaders(objOutfile) Set dicSchemaIDGUIDs = CreateObject("Scripting.Dictionary") Call dicSchemaIDGUIDs.Add("Seed", "xxx") Call CacheRightsGuids objCommand.CommandText = _ ";" & _ strLDAPFilter & ";" & _ "distinguishedName;" & _ SCOPE_STRING objCommand.Properties("Page Size") = 500 objCommand.Properties("Cache Results") = False ' do not cache the result, it results in less memory requirements Set objRecordset = objCommand.Execute Do While Not objRecordset.EOF Call DisplayOneObject(objRecordset.Fields("distinguishedName")) objRecordset.MoveNext Loop objConnection.Close Call objOutfile.Write(strTableEnd & strHTMLEnd) Call objOutfile.Close WScript.Echo "ACLReport complete." '===End of the Main Program=== '============================== Sub WriteHeaders(objOutfile) Call objOutfile.Write(strTHeaderRowStart) Call objOutfile.Write("Object" _ & strTColSep & "ACE#" _ & strTColSep & "Trustee" _ & strTColSep & "AccessMask" _ & strTColSep & "AM Interpr" _ & strTColSep & "AceFlags" _ & strTColSep & "Inherit (AF)" _ & strTColSep & "Inherit, No Propagate (AF)" _ & strTColSep & "Inherit Only (AF)" _ & strTColSep & "Inherited (AF)" _ & strTColSep & "AceType" _ & strTColSep & "AT Interpr" _ & strTColSep & "Flags" _ & strTColSep & "OT Present (Fl)" _ & strTColSep & "IOT Present (Fl)" _ & strTColSep & "ObjectType" _ & strTColSep & "OT Interpr" _ & strTColSep & "Inh ObjectType" _ & strTColSep & "IOT Interpr") Call objOutfile.Write(strTRowEnd) End Sub '============================== Sub DisplayOneObject(strDN) Dim strOut, bolACEInherited, bolACEDeny, strDNClean If bolCScript Then WScript.Echo "Writing the ACEs of " & strDN 'ADSI bind doesn't like a straight slash in DN strDNClean = Replace(strDN, "/", "\/", 1, -1, vbTextCompare) Set objADObject = GetObject("LDAP://" & strDNClean) Set objSecDesc = objADObject.Get("ntSecurityDescriptor") Set objDACL = objSecDesc.DiscretionaryAcl i = 0 For Each objACE In objDACL i = i + 1 bolACEDeny = False strOut = _ CleanHTML(strDN) & strTColSep & _ "ACE " & i & strTColSep & _ CleanHTML(objACE.Trustee) & strTColSep & _ GetAccessMaskBits(objACE.AccessMask) & strTColSep & _ GetAceFlagBits(objACE.AceFlags, bolACEInherited) & strTColSep & _ GetStringAceType(objACE.AceType, bolACEDeny) & strTColSep & _ GetFlagBits(objACE.Flags) & strTColSep & _ GetObjectType(objACE.ObjectType) & strTColSep & _ GetInheritedObjectType(objACE.InheritedObjectType) If SCOPE_ALL_ACES Or Not bolACEInherited Then If Not bolACEInherited And Not bolACEDeny Then strOut = strTNormalRowStart & strOut If bolACEInherited And Not bolACEDeny Then strOut = strTInheritedRowStart & strOut If Not bolACEInherited And bolACEDeny Then strOut = strTDenyRowStart & strOut If bolACEInherited And bolACEDeny Then strOut = strTInheritedDenyRowStart & strOut Call objOutfile.Write(strOut & strTRowEnd) End If Next End Sub '============================== Function CleanHTML(strInput) Dim strCleaned strCleaned = Replace(strInput, "<", "<", 1, -1, vbTextCompare) strCleaned = Replace(strInput, ">", ">", 1, -1, vbTextCompare) strCleaned = Replace(strInput, "&", "&", 1, -1, vbTextCompare) strCleaned = Replace(strInput, Chr(34), """, 1, -1, vbTextCompare) CleanHTML = strCleaned End Function '============================== Function GetAccessMaskBits(intBitfield) Dim strOut, i, bolFoundMatch, bolFirstMatch strOut = Hex(intBitfield) & strTColSep bolFoundMatch = False For i = LBound(arrADSRightCombinations) To UBound(arrADSRightCombinations) If intBitfield = arrADSRightCombinations(i,1) Then strOut = strOut & arrADSRightCombinations(i,0) bolFoundMatch = True Exit For End If Next If Not bolFoundMatch Then bolFirstMatch = True For i = LBound(arrADSRights) To UBound(arrADSRights) If intBitfield And arrADSRights(i,1) Then If bolFirstMatch Then strOut = strOut & arrADSRights(i,0) Else strOut = strOut & ", " & arrADSRights(i,0) End If bolFirstMatch = False End If Next End If GetAccessMaskBits = strOut End Function '============================== Function GetAceFlagBits(intBitfield, ByRef bolACEInherited) Dim strOut, i strOut = Hex(intBitfield) & strTColSep For i = 0 To 3 'Inherit, No Propagate, Inherit_only, Inherited If intBitfield And arrADSACEFlags(i,1) Then strOut = strOut & YES Else strOut = strOut & NBSP End If If i < 3 Then strOut = strOut & strTColSep Next If intBitfield And arrADSACEFlags(3,1) Then bolACEInherited = True Else bolACEInherited = False End If GetAceFlagBits = strOut End Function '============================== Function GetStringAceType(intACEType, ByRef bolACEDeny) Dim strOut, i strOut = "unknown ACE type" For i = LBound(arrADSACETypes) To UBound(arrADSACETypes) If intACEType = arrADSACETypes(i,1) Then strOut = arrADSACETypes(i,0) End If Next bolACEDeny = (intACEType = arrADSACETypes(1,1)) Or (intACEType = arrADSACETypes(4,1)) GetStringAceType = Hex(intACEType) & strTColSep & strOut End Function '============================== Function GetFlagBits(intBitfield) Dim strOut, i strOut = Hex(intBitfield) & strTColSep For i = 0 To 1 'Object type present, Inherited object type present If intBitfield And arrADSFlags(i,1) Then strOut = strOut & YES Else strOut = strOut & NBSP End If If i < 1 Then strOut = strOut & strTColSep Next GetFlagBits = strOut End Function '============================== Function GetObjectType(strGUID) GetObjectType = strGUID & strTColSep & CleanHTML(MapGUIDToMatchingName(strGUID)) End Function '============================== Function GetInheritedObjectType(strGUID) GetInheritedObjectType = strGUID & strTColSep & CleanHTML(MapGUIDToMatchingName(strGUID)) End Function '============================== Sub CacheRightsGuids() Dim objExtRights, objChild, intCounter If bolCScript Then WScript.Echo "Caching extended right and property set names..." Set dicRightsGuids = CreateObject("Scripting.Dictionary") Set objExtRights = GetObject("LDAP://CN=Extended-Rights," & _ objDSE.Get("configurationNamingContext")) intCounter = 0 For Each objChild In objExtRights 'Actually all should be of the same class If objChild.Class = "controlAccessRight" Then If (objChild.validAccesses And &H130) > 0 Then 'filter out garbage, such as 'cn=Validated-DNS-Host-Name intCounter = intCounter + 1 Call dicRightsGuids.Add( _ UCase("{" & objChild.Get("rightsGuid") & "}"), _ objChild.Get("displayName")) If intCounter Mod 20 = 0 Then If bolCScript Then WScript.Echo "Processed " & intCounter & _ " extended rights and/or property sets" End If End If End If Next If bolCScript Then WScript.Echo "Extended right and property set names cached" End Sub '============================== Function MapGUIDToMatchingName(strGUIDAsString) Dim strOut, objSchemaRecordset, strLDAPname If strGUIDAsString = "" Then Exit Function strOut = "" If dicRightsGuids.Exists(UCase(strGUIDAsString)) Then strOut = dicRightsGuids.Item(UCase(strGUIDAsString)) End If If strOut = "" Then 'Didn't find a match in extended rights If dicSchemaIDGUIDs.Exists(UCase(strGUIDAsString)) Then strOut = dicSchemaIDGUIDs.Item(UCase(strGUIDAsString)) Else objCommand.CommandText = _ ";" & _ "(schemaIDGUID=" & GUIDStrFormatToEscapeBinFormat(strGUIDAsString) & ");" & _ "lDAPDisplayName;subTree" Set objSchemaRecordset = objCommand.Execute If Not objSchemaRecordset.EOF Then strLDAPname = objSchemaRecordset.Fields("lDAPDisplayName") Call dicSchemaIDGUIDs.Add(UCase(strGUIDAsString), strLDAPname) strOut = strLDAPname End If End If End If MapGUIDToMatchingName = strOut End Function '============================== Function GetSchemaIDGUID(objSchemaObj) Dim arrValue, i, strByte, strGUID arrValue = objSchemaObj.Get("schemaIDGUID") strGUID = "" For i = 1 to LenB(arrValue) strByte = Hex(AscB(MidB(arrValue, i, 1))) If Len(strByte) = 1 Then strByte = "0" & strByte strGUID = strGUID & strByte Next GetSchemaIDGUID = GuidBinFormatToStrFormat(strGUID) End Function '============================== Function GUIDBinFormatToStrFormat(strGUIDBin) Dim i, strDest Dim arrBytes(16) 'We will use elements 1 to 16 but not 0 For i = 1 To 16 'A GUID has 16 bytes arrBytes(i) = Mid(strGUIDBin, 2 * i - 1, 2) Next strDest = "{" For i = 1 To 4 : strDest = strDest & arrBytes(5 - i) : Next strDest = strDest & "-" For i = 1 To 2 : strDest = strDest & arrBytes(7 - i) : Next strDest = strDest & "-" For i = 1 To 2 : strDest = strDest & arrBytes(9 - i) : Next strDest = strDest & "-" For i = 1 To 2 : strDest = strDest & arrBytes(8 + i) : Next strDest = strDest & "-" For i = 1 To 6 : strDest = strDest & arrBytes(10 + i) : Next strDest = strDest & "}" GuidBinFormatToStrFormat = strDest End Function '============================== Function GUIDStrFormatToEscapeBinFormat(strGUID) Dim i, strDest, strDest2 Dim arrBytes(16) 'We will use elements 1 to 16 but not 0 strDest = Replace(strGUID, "{", "", 1, -1, vbTextCompare) strDest = Replace(strDest, "}", "", 1, -1, vbTextCompare) strDest = Replace(strDest, "-", "", 1, -1, vbTextCompare) strDest2 = "" For i = 1 To 4 : strDest2 = strDest2 & "\" & Mid(strDest, 2*4+1 - 2*i, 2) : Next For i = 1 To 2 : strDest2 = strDest2 & "\" & Mid(strDest, 2*6+1 - 2*i, 2) : Next For i = 1 To 2 : strDest2 = strDest2 & "\" & Mid(strDest, 2*8+1 - 2*i, 2) : Next For i = 1 To 2 : strDest2 = strDest2 & "\" & Mid(strDest, 2*8-1 + 2*i, 2) : Next For i = 1 To 6 : strDest2 = strDest2 & "\" & Mid(strDest, 2*10-1 + 2*i, 2) : Next GUIDStrFormatToEscapeBinFormat = strDest2 End Function '============================== Sub CheckWSHEnvironment(ByRef bolCScript) Dim strScriptHostName, intYesNo strScriptHostName = WScript.FullName strScriptHostName = Right(strScriptHostName, Len(strScriptHostName) _ - InStrRev(strScriptHostName,"\")) If UCase(strScriptHostName) = "CSCRIPT.EXE" Then bolCScript = True Else intYesNo = MsgBox( _ "You should run this script in the CScript" & vbCrLf & _ "command line environment to get a number of" & vbCrLf & _ "progress messages. Either type CSCRIPT" & vbCrLf & _ "before the script name or change CScript as" & vbCrLf & _ "the default environment with the command" & vbCrLf & _ "CSCRIPT //H:CSCRIPT" & vbCrLf & _ "" & vbCrLf & _ "You may now continue, but you won't see these" & vbCrLf & _ "progress messages (except the Complete message)." & vbCrLf & _ "" & vbCrLf & _ "Do you want to continue?", _ vbYesNo + vbQuestion + vbDefaultButton2, _ strTitleBar) If intYesNo = vbNo Then WScript.Quit(0) 'no error so no errorlevel Else bolCScript = False End If End If End Sub