'==========================================================================
' NAME: UserSummary.vbs
' Alan dot kaplan at va dot gov 1-23-06, 3-16-06
' 12/9/2009 added support for choosing initial OU/domain
' Gets basic user info for users.
' A cut and paste mess (still)
'==========================================================================
Option Explicit
On Error Resume Next
Dim i, message, sADSPath
Const ADS_SCOPE_ONELEVEL = 1
Dim root
Dim oConn, oCommand
dim wshShell
Set wshShell = WScript.CreateObject("WScript.Shell")
Dim Con 	'As ADODB.Connection
Dim gc 		'As IADs
Dim result, strText
Dim TopOU, strou, siteou,sdomain, rserver, displayon
Dim fso,ofolders, isnew,wsfile
Dim  RS
Set wshShell = WScript.CreateObject("WScript.Shell")
dim quote,title,path,newpath
Dim d,OUCN, sitecode, strUName, strAdsPath
Dim userobj
quote=chr(34)
Set d = CreateObject("Scripting.Dictionary")

Dim NTDom, objTrans
Const ADS_NAME_INITTYPE_GC = 3
Const ADS_NAME_TYPE_NT4 = 3
Const ADS_NAME_TYPE_1779 = 1

HostCheck

'Get the default ADsPath for the domain to search. 
Set root = GetObject("LDAP://rootDSE")
sADSPath = root.Get("defaultNamingContext")



' Use the NameTranslate object to find the NetBIOS domain name from the
' DNS domain name. (http://www.rlmueller.net/NameTranslateFAQ.htm#How%20do%20I%20find%20the%20NetBIOS%20name%20of%20the%20domain)
Set objTrans = CreateObject("NameTranslate")
objTrans.Init ADS_NAME_INITTYPE_GC, ""
objTrans.Set ADS_NAME_TYPE_1779, sADSPath
NTDom = objTrans.Get(ADS_NAME_TYPE_NT4)
' Remove trailing backslash.
NTDom = Left(NTDom, Len(NTDom) - 1)

'Connect to Activer 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

Dim sMyPath
sMyPath = strMyPath()

message = "This writes a summary of user information to a log file." & vbNewLine & vbNewLine  & _
"Start with what OU?"

sADSPath = InputBox(message,"Starting Path",sMyPath)
If sADSPath = "" Then WScript.Quit

SearchDom sADSPath

sADSPath = strAdsPath

' Create FileSystemObject object to access file system.
Set fso = WScript.CreateObject("Scripting.FileSystemObject")


'get path name, ending in \
Dim desktoppath, logfile, appendout
desktoppath = wshShell.ExpandEnvironmentStrings("%USERPROFILE%")& "\Desktop\"

logfile = desktoppath & left(WScript.ScriptName,Len(WScript.ScriptName)-3)& "xls"
logfile = InputBox("Log File", "Log File Path",logfile)
If logfile = "" Then WScript.Quit

Dim bCheckHD, retval 
bCheckHD = False
retval = MsgBox ("Check to see whether home directory exists (this requires admin access)?",vbYesNoCancel+vbQuestion+vbDefaultButton2,"Home Directory check?")
If retval = vbYes Then bCheckHD = True
If retval = vbCancel Then WScript.Quit

If fso.FileExists(logfile) Then fso.DeleteFile logfile,True

'setup log
Const ForAppend = 8
set AppendOut = fso.OpenTextFile(logfile, ForAppend, True)
appendout.WriteLine "Name	NTName	Description	When Acct Created	"& _
"PW Age days	Disabled	Act Expiration Date	Exp Date Passed	HomeDrive	HomeDirectory	Home Dir Exists	Account Location"

ADOQuery

'Show done
appendout.Close

SaveAsExcel logfile

wshShell.Popup "Done. Logfile is " & vbNewLine & logfile,20,"Script Complete" 

'''''''''''''''''''''''''''''''''''''''
' subroutines
'''''''''''''''''''''''''''''''''''''''

Sub SearchDom(sADSPath)
	Dim oRS
	Dim iChoice
	i = 1
	'Create a query
	Dim strCommand 
	strCommand = "SELECT Name, distinguishedname FROM 'GC://"& sADSPath & _
	"' WHERE objectClass='organizationalUnit'" & " or objectClass='domain'"
	oCommand.CommandText =strCommand
	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.
	
	message =""		'Build the menu
	
	For i = 0 To d.Count -1 ' Iterate the names 
	    message = message &   iChoice(i) & VbCrLf
	Next
	
	message = message & _
		"      --- Current Path ---- " & vbcrlf & _
	 "0) " & sADSPath & VbCrLf  
	
	iChoice = InputBox(message,"Navigate to Users OU",0)
	If iChoice = "" Then WScript.Quit
	If iChoice = "0" Then 
		strAdsPath = sADSPath
		Exit Sub
	End If 
	'okay.  This is a kludge. You could do this with a multidimensional array
	'or even a recordset. But it was fast and easy!
	
	Dim a,b
	a = d.Items
	b = d.Keys	'Cleaning up from menu stuff to get logfile
	On Error Resume Next	'ignore invalid entries
	logfile = b(iChoice-1)
	b = Split(logfile,")")
	logfile = Trim(b(1))
	sADSPath = a(iChoice-1)
	d.RemoveAll		'Clear the dictionary
	On Error GoTo 0
	searchDom sADSPath
	strAdsPath = sADSPath
End Sub



Sub ADOQuery()
	WScript.Echo sADSPath
	WScript.Echo "Executing AD query, please wait...."
	dim i
	Dim domain,sfilter, sAttribsToReturn, sDepth
	  Set domain = GetObject("LDAP://" & sADSPath)
	  If (Err.Number <> 0) Then
	     BailOnFailure Err.Number, "on GetObject for domain"
	  End If
	
	'Build the ADsPath element of the commandtext
	sADsPath = "<LDAP://" & sADSPath & ">"
	'set filter for users only 
	sFilter = "(&(objectCategory=person)(objectClass=user))"
	 
	'Build the returned attributes element of the commandtext.
	'name is netbios name distinguishedname is path
	sAttribsToReturn = "name,description,sAMAccountName,whenCreated,distinguishedname,homedirectory,homedrive,adspath"
		
	'Build the depth element of the commandtext.
	sDepth = "subTree"
	 
	'Assemble the commandtext.
	ocommand.CommandText = sADsPath & ";" & sfilter & ";" & sAttribsToReturn & ";" & sDepth
	'WScript.Echo oCommand.CommandText
	  If (Err.Number <> 0) Then
	     BailOnFailure Err.Number, "on CommandText"
	  End If

	ocommand.Properties("Page Size") = 500
	oCommand.Properties("Sort on") = "samAccountName"
	oCommand.Properties("Cache results") = False
	
	'Execute the query.
	Set RS = ocommand.Execute
	If (Err.Number <> 0) Then
	     BailOnFailure Err.Number, "on Execute"
	End If
	
	'WScript.Echo RS.recordcount & " users found"
	' Navigate the record Set
	'1RS.movelast
	rs.MoveFirst
	
	While Not rs.EOF
		GetInfo	
		rs.MoveNext
	Wend
End Sub

Function PWage()
	Dim  expNow
	expNow=userobj.Get("PasswordExpired") 
	'Convert PW Age from seconds to days
	PWage = Round((UserObj.PasswordAge/86400),0)
End Function

Sub GetInfo()
		Dim whenChanged
		Dim ExpDate 
		Dim strHomeDir
		Dim strDescription, tArray
		if IsArray(rs.Fields("description").Value) Then 
			tArray = rs.Fields("Description").Value
			strDescription = tArray(0)
		Else
			strDescription= (rs.Fields("Description").Value)
		End If 
		
		
		'WinNT required for some of the account control stuff
		Set userobj = GetObject("WinNT://"& NTDom & "/" & rs.Fields("sAMAccountName").Value)
		
		strUName = rs.Fields("Name").Value		
		message =  strUName & vbTab &  rs.Fields("sAMAccountName").Value & vbTab
		message = message & strDescription &  vbTab
		message = message & rs.Fields("WhenCreated").Value & vbTab 
		message = message & PWage ()& vbTab 
		message = message & UserObj.AccountDisabled & vbTab
		

		On Error Resume Next		
		Dim IFlag , strExpInfo
		
		IFlag=userobj.Get("UserFlags") 
		If (IFlag AND &H10000) <> 0	Then 
			strEXPInfo = "NEVER"
			message = message & vbTab & strExpInfo & vbTab 
		Else
			ExpDate = UserObj.AccountExpirationDate 
			If Err = 0 Then 
				strExpInfo=EXPInfo(ExpDate)
				message = message & ExpDate & vbTab 
				message = message & strExpInfo & vbTab 
			Else
				Err.Clear
				message = message & vbTab & vbTab 
			End If 	
		End If
			
		On Error GoTo 0
		
		message = message & rs.Fields("HomeDrive").value & vbTab 
		strHomeDir = rs.Fields("HomeDirectory").value
		message = message &  strHomeDir &  vbTab 
		
		
		If bCheckHD Then 
			If Len(strHomeDir) > 0 Then
				message = message & cbool(fso.FolderExists(strHomeDir)) & vbTab 
			Else
				message = message & "N/A	"
			End If 
		Else
				message = message & "Not checked	"
		End If 
		
		
		message = message & rs.Fields("adspath").value
		
  		echoandLog message
  		Err.Clear
  		On Error GoTo 0
End Sub


Function EXPInfo(dExpDate)	
	If DiffADate(dExpDate) > 0 Then 'Expired now?
		EXPInfo = "True"
	Else
		EXPInfo = "False"
	End If

End Function 


Sub EchoAndLog(message)
	WScript.Echo message
	appendout.WriteLine message
End Sub

Function IsCScript()
    If (InStr(UCase(WScript.FullName), "CSCRIPT") <> 0) Then
        IsCScript = True
    Else
        IsCScript = False
    End If
End Function

Function DiffADate(theDate) 
  DiffADate = DateDiff("d", thedate, now)
End Function

Sub BailOnFailure(ErrNum, ErrText)    strText = "Error 0x" & Hex(ErrNum) & " " & ErrText
    MsgBox strText, vbInformation, "ADSI Error"
    WScript.Quit
End Sub


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

Sub HostCheck
	If (Not IsCScript()) Then 		'If not CScript, re-run with cscript...
		dim quote, strArgs, i
		quote=chr(34)
		
		For i  = WScript.Arguments.Count -1 to  0 Step -1
			strArgs = WScript.Arguments(i) & Space(1) &  straArgs
		Next
		
		WshShell.Run "CScript.exe " & quote & WScript.ScriptFullName & quote & space(1) & strArgs, 1, true
	    WScript.Quit            	'...and stop running as WScript
	End If
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
	Dim tpath
	tPath = oTrans.Get(1)
	tPath = right(tPath,Len(tPath) - InStr(tPath,"OU")+1)
	strMyPath = ParentPath(tPath)
End Function 

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

Function IsCScript()
    If (InStr(UCase(WScript.FullName), "CSCRIPT") <> 0) Then
        IsCScript = True
    Else
        IsCScript = False
    End If
End Function

	
Sub SaveAsExcel(strFileName)
	WScript.Echo "Converting Log to Excel ..."
	Const xlnormal = -4143 
	Dim fso, oXL, objRange
	Set fso = CreateObject("Scripting.FileSystemObject")
	If Not fso.FileExists(strFileName) Then WScript.Quit
	On Error Resume Next
	Set oXL = CreateObject("Excel.Application")
	
	If Err <> 0 Then 'Excel not installed
		Err.Clear
		On Error GoTo 0
		Exit Sub
	End If 
	
	'oXL.Visible = True
	oXL.DisplayAlerts=False ' don't display overwrite prompt.
	oXL.Workbooks.Open(strFileName)
	Set objRange = oXL.Worksheets(1).UsedRange
	objRange.EntireColumn.Autofit()

	Dim oWS	
	Set oWS = oXL.Worksheets(1)
	oWS.Activate
	'oWS.Name = sdomain
	
	oXL.ActiveWorkBook.SaveAs strFileName,xlnormal,,,,,,,True 'overwrite existing
	oXL.ActiveWorkBook.Close
	oXL.Quit
	WScript.Echo "Done"
End Sub