'==========================================================================
' NAME: ComputersandUsers.vbs
'
' AUTHOR: Alan Kaplan
' Alan dot kaplan at va dot gov, alan at akaplan dot com
' 4-17-2009
' Based in small part on script by Rot Trent
' http://www.myitforum.com/articles/11/view.asp?id=5840
'
'==========================================================================
Option Explicit

dim wshShell
Set wshShell = WScript.CreateObject("WScript.Shell")
dim quote, message, retval, strType, strDelim
Dim fso
Dim strDTPath, appendout
Dim objRootDSE, objDOM, objOU
Dim strAdsPath
Dim oCommand
Dim iChoose
Const ForAppend = 8

strDelim = vbTab
quote=chr(34)
message = "This will dump list of users or computers to file with LDAP path and create times and dates."&_
	"Select search type:" & vbcrlf & vbcrlf &_
	"1) Users" & vbcrlf &_
	"2) Computers" & vbcrlf & vbcrlf &_
	"0) Quit" 
retval = InputBox(message,"Search Type",0)

Select Case retval
	Case 0
		WScript.Quit
	Case 1
		strType = "USER"
	Case 2
		strType = "COMPUTER"
	Case Else
		WScript.Quit
End Select

OUSearchInit

iChoose = InputBox( _
	"Start with what OU?" & vbcrlf  & vbcrlf &_
	"1) " & strAdsPath & VbCrLf  & _
	"2) " & strMyPath & VbCrLf,"Starting OU",0)

Select Case iChoose
	Case 1 
		SearchDom strAdsPath
	Case 2
		SearchDom strMyPath
	Case Else
		WScript.Quit
End Select 


Set fso = CreateObject("Scripting.FileSystemObject")
strDTPath = wshShell.ExpandEnvironmentStrings("%USERPROFILE%")& "\desktop\"

Set appendout = fso.createtextfile(strDTPath & strType &"_Accounts.xls",ForAppend, True)

appendout.writeline "Object Name	NT4 Name	UPN	Distinguished Name	Created	Last Changed"

TraverseOU "LDAP://" & strAdsPath

wshShell.Popup "Done.  Log file can be opened with Excel or Notepad",10,"Script Complete"

' ============= Functions and Subs =========

Sub TraverseOU(ByVal sADsPath)
	Dim objObject, objMyClass

	Set objOU = GetObject(sADsPath)
	For Each objObject In objOU
		If ucase(objObject.Class) = "ORGANIZATIONALUNIT" Then
			TraverseOU objObject.ADsPath
		End If
		If ucase(objObject.Class) = strType Then
			TraverseOU objObject.ADsPath
		End If
		
		If UCase(objObject.Class) = strType Then
			Set objMyClass = GetObject("LDAP://" & objObject.distinguishedName)
			echoandlog mid(objObject.name,4) & strDelim & objObject.samaccountname & strDelim & _
			objObject.userPrincipalName & strDelim & objObject.distinguishedName & strDelim &  _
			objMyClass.whenCreated & strDelim &  objMyClass.whenChanged  
		End If
	Next
End Sub

Sub SearchDom(strAdsPath)
	Dim d ' Create dictionary
	Set d = CreateObject("Scripting.Dictionary")
	Dim i, message

	Dim oRS
	Dim iChoice
	i = 1
	'Create a query
	oCommand.CommandText = _
	    "SELECT Name, distinguishedname FROM 'LDAP://"& strAdsPath &"' WHERE objectClass='organizationalUnit'"  
	Set oRS = oCommand.Execute
		
	If oRS.EOF = True Then	'no more OUs under.  Exit
		Exit Sub
	End If 
	
	oRS.MoveFirst
	Do Until oRS.EOF
		'Add the name and the dn -- here ADSPath to dictionary.
	    d.Add i &") " &  oRS.Fields("Name").Value, oRS.Fields("distinguishedname").Value
	    oRS.MoveNext
	    i = i + 1 
	Loop
	
	iChoice = d.Keys              ' Get the keys.
	'OUName = d.Items
	
	message =""		'Build the menu
	
	For i = 0 To d.Count -1 ' Iterate the names 
	    message = message &   iChoice(i) & vbcrlf
	Next
	
	message = message & "99) Go up to parent path" & vbcrlf &_
	vbcrlf & 	"      --- Current Path ---- " & vbcrlf & _
	 "0) " & strAdsPath  
	
	iChoice = InputBox(message,"Enter Choice",0)
	If iChoice = "" Then WScript.Quit
	If iChoice = 0 Then Exit Sub
	If iChoice = 99 Then 
		strAdsPath = ParentPath(strAdsPath)
	Else
		'okay.  This is a kludge, combining dictionary object
		'and arrays.  You could do this with a multidimensional array
		'or even a recordset. But it was fast and easy!
		
		Dim a
		a = d.Items
		strAdsPath = a(iChoice-1)
	End If
	 
	d.RemoveAll		'Clear the dictionary
	SearchDom strAdsPath 'recurse
End Sub

Function ParentPath(strAdsPath) 'what is above
	Dim IADSCont
	Set IADSCont = GetObject("LDAP://" & strAdsPath)
	ParentPath = mid(IADsCont.Parent,8)
End Function

Sub OUSearchInit()
	Const ADS_SCOPE_ONELEVEL = 1
	Dim root
	Dim oConn
	'Get the default ADsPath for the domain to search. 
	Set root = GetObject("LDAP://rootDSE")
	strAdsPath = root.Get("defaultNamingContext")
	
	'Connect to Active directory and search setup
	Set oConn = CreateObject("ADODB.Connection")
	Set oCommand =   CreateObject("ADODB.Command")
	oConn.Provider = "ADsDSOObject"
	oConn.Open "Active Directory Provider"
	Set oCommand.ActiveConnection = oConn
	oCommand.Properties("Page Size") = 1000
	'This is critical -  Pick something else and you get too much 
	oCommand.Properties("Searchscope") = ADS_SCOPE_ONELEVEL
End Sub

Function strMyPath()  'Get path of current user
	Dim objEnv, strMyName
	Dim strDNSDom 
	Dim oTrans, IADsCont
	set objEnv = WshShell.Environment("process")
	strMyName = objEnv("UserDomain") & "\" & objEnv("UserName")
	strDNSDom = objEnv("UserDNSDomain")
	Set oTrans = CreateObject("NameTranslate")
	oTrans.Init 1, strDNSDom
	oTrans.Set 3,strMyName
	strMyPath = oTrans.Get(1)
	strMyPath = right(strMyPath,Len(strMyPath) - InStr(strMyPath,"OU")+1)
	strMyPath = ParentPath(strMyPath)
End Function 

Sub EchoAndLog (message)
	'Echo output and write to log
	Wscript.Echo message
	AppendOut.WriteLine message
End Sub