Option Explicit

' Enumerates Active Directory contents for logged on user's domain. N.B. By commenting the line 'DomainObj.Filter = Array( "user", "computer", "group" )'
' back in you may filter the objects listed.

'  6 Dec 2003					Using XML for output.
'  4 Dec 2000 Rolf Åberg		Inspired by various scripts found on the Net.

' (c) Copyright 2000, 2003 Rolf Åberg, mailto:rolf.aberg@simplex.se. Free for all and all non-commercial use provided this line is retained.

Const ForWriting				= 2				' Scripting.FileSystemObject.ForWriting.
Const LdapPrefix				= "LDAP://"

Dim Fso							' Scripting.FileSystemObject.
Dim OutputFile					' FileSystemObject.TextStream.
Dim WshNetwork					' To get to the currently logged on user's information.
Dim LdapObj						' Our LDAP connexion.
Dim NameSpace					' Name spaces found in the LDAP object. Should be only one!
Dim DomainObj					' An object in the domain, container or otherwise.
Dim ContainerObjs()				' Collection of AD objects in a container.
Dim AdObj						' Single AD object.
Dim ObjDn						' Distinguished name for AD object.
Dim RootDse						' Root DSE Information.


Set Fso = CreateObject( "Scripting.FileSystemObject" )


On Error Resume Next

Set WshNetwork = CreateObject( "WScript.Network" )
Set RootDse = GetObject( LdapPrefix & "RootDSE" )

Set OutputFile = Fso.OpenTextFile( RootDse.Get( "defaultNamingContext") & ".xml", ForWriting, True)
OutputFile.WriteLine "<?xml version=""1.0"" encoding=""ISO-8859-1""?>"
OutputFile.WriteLine "<ADContents>"
OutputFile.WriteLine Space( 2 ) & "<Info>"
OutputFile.WriteLine Space( 4 ) & "<Date>"						& FormatDateTime( Now(), vbGeneralDate ) & "</Date>"
OutputFile.WriteLine Space( 4 ) & "<UserAccountName>"			& WshNetwork.UserName & "</UserAccountName>"
OutputFile.WriteLine Space( 4 ) & "<UserAccountDomainName>"		& WshNetwork.UserDomain & "</UserAccountDomainName>"
OutputFile.WriteLine Space( 4 ) & "<ComputerName>"				& WshNetwork.ComputerName & "</ComputerName>"
OutputFile.WriteLine Space( 4 ) & "<DomainController>"
OutputFile.WriteLine Space( 6 ) & "<ServerName>"				& RootDse.Get( "serverName") & "</ServerName>"
OutputFile.WriteLine Space( 6 ) & "<DNSHostName>"				& RootDse.Get( "dnsHostName") & "</DNSHostName>"
OutputFile.WriteLine Space( 6 ) & "<CurrentTime>"				& RootDse.Get( "currentTime") & "</CurrentTime>"
OutputFile.WriteLine Space( 6 ) & "<DefaultNamingContext>"		& RootDse.Get( "defaultNamingContext") & "</DefaultNamingContext>"
OutputFile.WriteLine Space( 6 ) & "<SchemaNamingContext>"		& RootDse.Get( "schemaNamingContext") & "</SchemaNamingContext>"
OutputFile.WriteLine Space( 6 ) & "<ConfigurationNamingContext>" & RootDse.Get( "configurationNamingContext") & "</ConfigurationNamingContext>"
OutputFile.WriteLine Space( 6 ) & "<HighestCommittedUSN>"		& RootDse.Get( "highestCommittedUsn") & "</HighestCommittedUSN>"
OutputFile.WriteLine Space( 6 ) & "</DomainController>"
OutputFile.WriteLine Space( 4 ) & "</Info>"

Set LdapObj = GetObject( "LDAP:" )
For Each NameSpace in LdapObj

	ReDim ContainerObjs( 0 )
	EnumAllContainers NameSpace.AdsPath, ContainerObjs
	ReDim Preserve ContainerObjs( UBound( ContainerObjs) - 1)	' We always add one extra so we have to remove it, too.

	Dim ContNum
	For ContNum = LBound( ContainerObjs ) To UBound( ContainerObjs )
		Set DomainObj = GetObject( ContainerObjs( ContNum ) )
		ObjDn = Mid( ContainerObjs( ContNum), Len( LdapPrefix ) + 1 )
		OutputFile.WriteLine Space( 2 ) & "<Object Class=""" & DomainObj.Class & """ DN=""" & ObjDn & """>"
'		DomainObj.Filter = Array( "user", "computer", "group" )
		For Each AdObj In DomainObj
			OutputFile.WriteLine Space( 4 ) & "<Object Class=""" & AdObj.Class & """ DN=""" & Mid( AdObj.AdsPath, Len( LdapPrefix ) + 1 ) & """/>"
		Next
		OutputFile.WriteLine Space( 2 ) & "</Object>"
	Next
Next
OutputFile.WriteLine "</ADContents>"
OutputFile.Close


Private Sub EnumAllContainers( ContainerAdsPath, Containers() )

	Dim ContObj
	Dim ChildObj

	Set ContObj = GetObject( ContainerAdsPath )

	If Err.Number = 0 Then
		Containers( UBound( Containers)) = ContainerAdsPath
		ReDim Preserve Containers( UBound( Containers) + 1)
		For Each ChildObj In ContObj
			If (ChildObj.Class = "organizationalUnit") Or (ChildObj.Class = "builtinDomain") Or (ChildObj.Class = "container") Then
				EnumAllContainers ChildObj.AdsPath, Containers
			End If
		Next
	Else
		MsgBox ContObj.AdsPath & " " & ContObj.Class & " " & Err.Number
	End If

End Sub


Private Function CountOuLevel( ContainerAdsPath )
	Dim TextPos
	Dim OusCounted
	OusCounted = 0
	TextPos = 0
	Do
		TextPos = InStr( TextPos + 1, ContainerAdsPath, "OU=")
		If TextPos > 0 Then
			OusCounted = OusCounted + 1
		End If
	Loop While TextPos > 0
	CountOuLevel = OusCounted
End Function