‘Who Has Access - By Alan Mosley, ThatsIT Solutions Australia
'Writes report to text file, showing who has access to Exchange users mailboxes
'Must be run on email Server
Const DOMAIN = "IT"
Const EMAIL_SERVER = "HANK"
Const LDAP_DOMAIN = "LDAP://dc=ThatsIT,dc=local"
Dim objUser
Dim oSecurityDescriptor
Dim dacl
Dim ace
Dim fso:Set fso = CreateObject("Scripting.FileSystemObject")
set tf = fso.CreateTextFile("WhoHasAccess.txt",true)
getUsers(DOMAIN)
tf.WriteLine "Who Has Access - By Alan Mosley, ThatsIT Solutions Australia"
tf.close
Sub getUsers( strDomain )
Set objComputer = GetObject("WinNT://" & strDomain )
objComputer.Filter = Array( "User" )
For Each objUser In objComputer
writeACEs objUser.Name
Next
End Sub
sub writeACEs(userName)
On Error Resume Next
Const ADS_SCOPE_SUBTREE = 10
Set objConnection = CreateObject("ADODB.Connection")
Set objCommand = CreateObject("ADODB.Command")
objConnection.Provider = "ADsDSOObject"
objConnection.Open "Active Directory Provider"
Set objCommand.ActiveConnection = objConnection
objCommand.Properties("Page Size") = 1000
objCommand.Properties("Searchscope") = ADS_SCOPE_SUBTREE
objCommand.CommandText = _
"SELECT distinguishedName FROM '"& LDAP_DOMAIN &"' WHERE objectCategory='user' " & _
"AND sAMAccountName='"& userName &"'"
Set objRecordSet = objCommand.Execute
dim ans
objRecordSet.MoveFirst
Do Until objRecordSet.EOF
ans = objRecordSet.Fields("distinguishedName").Value
objRecordSet.MoveNext
Loop
set objUser = GetObject("LDAP://"& EMAIL_SERVER &"/"& ans)
Dim fullName:fullName = Trim( objUser.FullName)
if objUser.HomeMDB <> "" then
Set oSecurityDescriptor = objUser.MailboxRights
Set dacl = oSecurityDescriptor.DiscretionaryAcl
tf.WriteLine objUser.FullName
tf.WriteLine spaceIt("Trustee",30) & spaceIt("AccessMask",11) & spaceIt("ACEType",11) & _
spaceIt("ACEFlags",11) & spaceIt("Flags",11)
For Each ace In dacl
tf.WriteLine spaceIt(ace.Trustee,30) & spaceIt(ace.AccessMask,11) & _
spaceIt(ace.AceType,11) & spaceIt(ace.AceFlags,11) & spaceIt(ace.Flags,11)
Next
tf.WriteLine
tf.WriteLine
end if
end sub
function spaceIt(val,spaceCount)
dim aLine , dLen
aLine = val
dLen = len(aLine)
dLen = spaceCount - dLen
for i = 1 to dLen
aLine = aLine & " "
next
spaceIt = aLine
end function