'==========================================================================
'
' NAME: EnumLDAPUsersContainers.vbs
'
' AUTHOR: Mark D. MacLachlan , The Spider's Parlor
' URL: [URL unfurl="true"]http://www.thespidersparlor.com[/URL]
' DATE : 7/27/2004
'
' COMMENT: <comment>
'
'==========================================================================
Dim objRootDSE, strForest, objForest, strDom
Dim objCommand, objConnection
Set objRootDSE = GetObject("LDAP://RootDSE")
strForest = objRootDSE.Get("rootDomainNamingContext")
Set objForest = GetObject("LDAP://" & strForest)
strDom = objRootDSE.Get("defaultNamingContext")
' Use ADO to search Active Directory.
Set objCommand = CreateObject("ADODB.Command")
Set objConnection = CreateObject("ADODB.Connection")
objConnection.Provider = "ADsDSOObject"
objConnection.Open "Active Directory Provider"
objCommand.ActiveConnection = objConnection
objCommand.Properties("Page Size") = 100
objCommand.Properties("Timeout") = 30
objCommand.Properties("Cache Results") = False
GetDoms = EnumDomains(objForest)
' Clean up.
objConnection.Close
Set objRootDSE = Nothing
Set objForest = Nothing
Set objCommand = Nothing
Set objConnection = Nothing
Function EnumDomains(objParent)
' Recursive subroutine to enumerate domains.
Dim objGroup, objContainer, objChild
' Output domain name.
report = report & vbCrLf & "Domain: " & strDom & vbCrLf
' Enumerate containers in domain.
objParent.Filter = Array("container","organizationalUnit","builtinDomain")
For Each objContainer In objParent
If left(objContainer.distinguishedName,8) = "CN=Users" Or left(objContainer.distinguishedName,2) = "OU" Then
report = report & vbCrLf & EnumContainers(objContainer, objParent.distinguishedName)
report = report & vbCrlf
End If
Next
Set objGroup = Nothing
Set objContainer = Nothing
Set objChild = Nothing
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.CreateTextFile ("enumOU.txt", ForWriting)
ts.write report
set ts = nothing
set fso = nothing
End Function
Function EnumContainers(objParent, strDNSDomain)
On Error Resume Next
'MsgBox objParent.name & vbcrlf & strDNSDomain
' Recursive subroutine to enumerate containers.
Dim objGroup, objChild
' Output container name
'If Left(objParent.distinguishedname, 2) <> "CN" Then
report = report & objParent.distinguishedname
'End If
' Enumerate users in container.
objParent.Filter = Array("person")
For Each objPerson In objParent
ldappath = GetUser2(objPerson.name, objParent.Name, strDom)
If Left(objPerson.objectCategory, 9) = "CN=Person" Then
report = report & vbCrLf & vbTab & vbTab & objPerson.name & "," & objParent.distinguishedName
End If
Next
' Enumerate child containers.
objParent.Filter = Array("container","organizationalUnit","builtinDomain")
For Each objContainer In objParent
If Left(objContainer.DistinguishedName, 2) = "OU" Then
report = report & vbCrLf & vbTab & EnumContainers(objContainer, objParent.distinguishedName)
report = report & vbCrlf
End If
Next
EnumContainers = report
Set objGroup = Nothing
Set objChild = Nothing
End Function
Public Function GetUser2(ByVal sAMAccountName, LDOMAIN, StrDom)
On Error Resume Next
Dim ADCon,ADCmd,ADRec,str
Set ADCon = CreateObject("ADODB.Connection")
Set ADCmd = CreateObject("ADODB.Command")
ADCon.Provider = "ADsDSOObject"
ADCon.Open "Active Directory Provider", UID, PWD
Set ADCmd.ActiveConnection = ADCon
ADCmd.Properties("Cache results") = False
ADCmd.Properties("TimeOut") = 120
str = "select sAMAccountName, ADsPath " & _
"from '" & LDOMAIN & "," & StrDom & "' " & _
"where objectCategory='person' and sAMAccountName='" & sAMAccountName & "'"
ADCmd.CommandText = str
Set ADRec = ADCmd.Execute()
If ADRec.EOF Then
Set objUser = Nothing
Exit Function
End If
' Then bind to the IADs object.
Set GetUser2 = getObject(ADRec.Fields("adspath"))
End Function
