' -------------------------------------------------------------------------
'       From the book Inside Active Directory, ISBN 0-201-61621-1
'       Copyright (C) 2002 by Addison-Wesley
'       Script by Sakari Kouti (see http://www.kouti.com)
' You have a royalty-free right to use, modify, reproduce and distribute
' this script (and/or any modified version) in any way you find useful,
' provided that you agree that Addison-Wesley or Sakari Kouti has no
' warranty, obligations or liability for the script. If you modify
' the script, you must retain this copyright notice.
' -------------------------------------------------------------------------
Option Explicit

'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) = "DS_CREATE_CHILD"
arrADSRights(0,1) = &H1
arrADSRights(1,0) = "DS_DELETE_CHILD"
arrADSRights(1,1) = &H2
arrADSRights(2,0) = "ACTRL_DS_LIST"
arrADSRights(2,1) = &H4
arrADSRights(3,0) = "DS_SELF"
arrADSRights(3,1) = &H8
arrADSRights(4,0) = "DS_READ_PROP"
arrADSRights(4,1) = &H10
arrADSRights(5,0) = "DS_WRITE_PROP"
arrADSRights(5,1) = &H20
arrADSRights(6,0) = "DS_DELETE_TREE"
arrADSRights(6,1) = &H40
arrADSRights(7,0) = "DS_LIST_OBJECT"
arrADSRights(7,1) = &H80
arrADSRights(8,0) = "DS_CONTROL_ACCESS"
arrADSRights(8,1) = &H100
arrADSRights(9,0) = "DELETE"
arrADSRights(9,1) = &H10000
arrADSRights(10,0) = "READ_CONTROL"
arrADSRights(10,1) = &H20000
arrADSRights(11,0) = "WRITE_DAC"
arrADSRights(11,1) = &H40000
arrADSRights(12,0) = "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

'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) = "ACCESS_ALLOWED"
arrADSACETypes(0,1) = 0
arrADSACETypes(1,0) = "ACCESS_DENIED"
arrADSACETypes(1,1) = &H1
arrADSACETypes(2,0) = "SYSTEM_AUDIT"
arrADSACETypes(2,1) = &H2
arrADSACETypes(3,0) = "ACCESS_ALLOWED_OBJECT"
arrADSACETypes(3,1) = &H5
arrADSACETypes(4,0) = "ACCESS_DENIED_OBJECT"
arrADSACETypes(4,1) = &H6
arrADSACETypes(5,0) = "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 objDSE, strDefaultDN, strDN, objADObject, i
Dim objSecDesc, objDACL, objACE

'===The Main Program===

Set objDSE = GetObject("LDAP://rootDSE")
strDefaultDN = "CN=Users," & objDSE.Get("defaultNamingContext")

strDN = 	InputBox("Enter the distinguished name of an object" & _
	vbCrLf & "(e.g. " & strDefaultDN & ")", , strDefaultDN)

If strDN = "" Then WScript.Quit(0)  'user clicked Cancel

Set objADObject = GetObject("LDAP://" & strDN)

Set objSecDesc = objADObject.Get("ntSecurityDescriptor")
Set objDACL = objSecDesc.DiscretionaryAcl

WScript.Echo "Number of ACEs: " & objDACL.AceCount

i = 0
For Each objACE In objDACL
	i = i + 1
	WScript.Echo ""
	WScript.Echo "ACE " & i
	WScript.Echo "Trustee: " & objACE.Trustee
	WScript.Echo GetStringBits("AccessMask", _
		objACE.AccessMask, arrADSRights)
	WScript.Echo GetStringBits("AceFlags", _
		objACE.AceFlags, arrADSACEFlags)
	WScript.Echo GetStringAceType(objACE.AceType)
	WScript.Echo GetStringBits("Flags", _
		objACE.Flags, arrADSFlags)
	WScript.Echo GetObjectType(objACE.ObjectType)
	WScript.Echo GetInheritedObjectType(objACE.InheritedObjectType)
Next

'===End of the Main Program===
'==============================

Function GetStringBits(strName, intBitfield, arrBits)
	Dim strOut, i

	strOut = strName & ": " & Hex(intBitfield)

	For i = LBound(arrBits) To UBound(arrBits)
		If intBitfield And arrBits(i,1) Then
			strOut = strOut & ", " & arrBits(i,0)
		End If
	Next

	GetStringBits = strOut
End Function

'==============================

Function GetStringAceType(intACEType)
	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

	GetStringAceType = "AceType: " & Hex(intACEType) & ", " & strOut
End Function

'==============================

Function GetObjectType(strGUID)
	GetObjectType = "ObjectType: " & _
		strGUID & " " & MapGUIDToMatchingName(strGUID)
End Function

'==============================

Function GetInheritedObjectType(strGUID)
	GetInheritedObjectType = "InheritedObjectType: " & _
		strGUID & " " & MapGUIDToMatchingName(strGUID)
End Function

'==============================

Function MapGUIDToMatchingName(strGUIDAsString)
	Dim strOut, objExtRights, objChild, objSchema

	If strGUIDAsString = "" Then Exit Function

	strOut = ""

	Set objExtRights = GetObject("LDAP://CN=Extended-Rights," & _
		objDSE.Get("configurationNamingContext"))

	For Each objChild In objExtRights
		'Actually all should be of the same class
		If objChild.Class = "controlAccessRight" Then
			If	UCase("{" & objChild.Get("rightsGuid") & "}") = _
				UCase(strGUIDAsString) Then
				strOut = objChild.Get("cn") & ":" & _
					objChild.Get("displayName")
				Exit For
			End If
		End If
	Next

	If strOut = "" Then  'Didn't find a match in extended rights
		Set objSchema = GetObject("LDAP://" & _
			objDSE.Get("schemaNamingContext"))

		For Each objChild In objSchema
			If objChild.Class = "classSchema" Or _
			   objChild.Class = "attributeSchema" Then
				If	UCase(GetSchemaIDGUID(objChild)) = _
					UCase(strGUIDAsString) Then
					strOut = objChild.Get("cn") & ":" & _
						objChild.Get("lDAPDisplayName")
					Exit For
				End If
			End If
		Next
	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