'ADCounts.vbs v 2
'Alan Kaplan, alan dot kaplan at va dot gov
'This script does basic count of servers, workstaitions, users OU
'alan at akaplan dot com, alan dot kaplan at med dot va dot gov
'AD does not distinguish NT workstations from server
'Revision 6-30-05 Added count of users excluding probable 
'service accounts and disabled accounts
'Added workstation count for not disabled and contacted with default of 90 days.
'original 6-28-05
'11-28-05 v 1.1 Added OU to logfile name.
'7-26-05 v 1.2 added count of mail enabled users
'1-12-07 v 1.3 separated XP/2003 from 2000 counts, fixed NT  4 
'2-9-2009 v 1.4 added active user accounts
'9-0-09 v 1.5 added 2008, Vista, and Windows 7
'12-10-2009 added support for different starting domain
'3/12 added  prompt for max days
'3/24 v 2.0 added support for navigation to starting OU

'''''''''''' ADD count of objects and navigation to initial OU

Option Explicit
Dim d ' Create dictionary
Set d = CreateObject("Scripting.Dictionary")
Dim i, message, sADSPath
Const ADS_SCOPE_ONELEVEL = 1
Const ADS_SCOPE_SUBTREE = 2
Dim root, strOUDomain
Dim oConn, oCommand, objRecordSet
Dim strCount, strTxt, rsArray, iRC
Dim iComputerMax,iUserMax
'default aging info
iUserMax = 120
'You can change this to a different period. Default is Win2k and XP every 90 days.
iComputerMax = 90
Dim strQuery
dim wshShell
Set wshShell = WScript.CreateObject("WScript.Shell")
Dim quote
quote=chr(34)


If (Not IsCScript()) Then 		'If not CScript, re-run with cscript...
	WshShell.Run "CScript.exe " & quote & WScript.ScriptFullName & quote , 1, true
    WScript.Quit            	'...and stop running as WScript
End If

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

'Connect to Active directory and search setup 
'For menu that navigates AD
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") = 100
oCommand.Properties("Searchscope") = ADS_SCOPE_ONELEVEL

Dim retval
message = "This script counts server, workstation and user " & _
"accounts within any OU." 

retval = MsgBox(message,vbOKCancel,"Welcome")
If retval = vbCancel Then WScript.Quit

dim fso,logfile, appendout
Dim iComputerAgeAgo,  iUserDaysAgo

sADSPath = InputBox("Start navigation to select OU where?","Start LDAP Path",sADSPath)
If sADSPath = "" Then WScript.Quit

SearchDom sADSPath

iUserMax =InputBox("Count user accounts as stale if no password change how many days?","User days",iUserMax)
If iUserMax = "" Then WScript.Quit
iComputerMax = InputBox("Count computer accounts as stale if no password change how many days?","Computer days",iComputerMax)
If iComputerMax = "" Then WScript.Quit


iComputerAgeAgo = (Date - iComputerMax)
iUserDaysAgo = (Date - iUserMax)

'setup log
Const ForAppend = 8
set fso = CreateObject("Scripting.FileSystemObject")



Dim bHeader			'Do we need a first line?
bHeader = True

Dim strOUName, tarray
tarray = Split(sADSPath,",")
If instr(tarray(0),"=") > 0 Then 
	strOUName = replace(tarray(0),"=","_")
End If

logfile = wshShell.ExpandEnvironmentStrings("%userprofile%") & "\desktop\" & strOUName & "_AD_Counts.txt"
logfile = InputBox("Path to logfile","Edit Path",logfile)

If fso.FileExists(logfile) Then 
	message = 	logfile  & " exists.  Overwrite it? (No will append)"
	retval = MsgBox(message, vbyesno + vbquestion,"Overwrite?")
	If retval = vbYes Then 
		fso.DeleteFile(logfile)
	Else
		bHeader = False
	End If 
End If 

set AppendOut = fso.OpenTextFile(logfile, ForAppend, True)

EchoAndLog "Active Directory Counts for object within " & sADSPath & " and below." &  VbCrLf 
EchoandLog "Servers:"
GetCounts "2008Servers"
GetCounts "Active2008"
GetCounts "2003Servers"
GetCounts "Active2003"
GetCounts "2000Servers"
GetCounts "Active2000"
GetCounts "AllServers" 'Should match added up 

EchoAndLog VbCrLf & "Workstations:"
GetCounts "Win7"
GetCounts "ActiveWin7"
GetCounts "Vista"
GetCounts "ActiveVista"
GetCounts "XPPro"
GetCounts "ActiveXPPro"
GetCounts "W2KPro"
GetCounts "ActiveW2KPro"
GetCounts "AllWKS" ' should match added up

EchoAndLog VbCrLf & "NT 4:"
GetCounts "NT4"

EchoAndLog VbCrLf & "Users:"
GetCounts "Users"
GetCounts "NotService"
GetCounts "ActiveNotService"
GetCounts "MailEnabled"

appendout.WriteLine VbCrLf & VbCrLf & "AD query ran " & Date & " at " & Time & VbCrLf 
appendout.Close

MsgBox "Done. The logfile is " & logfile,vbinformation,"Count Complete"
wshShell.Run(quote & logfile & quote)

WScript.Quit

'========= Functions And Subs ==========
sub SearchDom(sADSPath)
	'basic menu to navigate through AD
	Dim oRS
	Dim iChoice, oADTmp
	i = 1
	'Create a query
	Dim strCommand
	strCommand = "SELECT Name, CanonicalName,distinguishedname FROM 'GC://"& sADSPath & _
	"' WHERE objectClass='organizationalUnit'" & " or objectClass='domain'"
	oCommand.CommandText =strCommand
	'WScript.Echo strCommand
	
	Set oRS = oCommand.Execute
	
	If oRS.EOF = True Then	'no more OUs under.  Exit
		Exit Sub
	End If 
	
	oRS.MoveFirst
	'Get the domain of the OU we are working on 
	tarray = oRS.Fields("CanonicalName").value
	strOUDomain = tarray(0)
	tarray = Split(strOUDomain,"/")
	strOUDomain = tarray(0)

	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 & _
		"      --- Current Path ---- " & vbcrlf & _
	 " 0) " & sADSPath & vbcrlf & vbcrlf & _
	 "-1)  Move up to parent path"  
	
	iChoice = InputBox(message,"Enter Choice, Click [OK]",0)
	If iChoice = "" Then WScript.Quit
	If iChoice = "0" Then Exit Sub
	If iChoice = "-1" Then
		set oADTmp = GetObject("GC://" & sADSPath)
		sADSPath = mid(oADTmp.Parent,6)
		d.RemoveAll
		searchDom sADSPath
	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!
	On Error Resume Next ' ignore numbers not in the list
	Dim a,b
	a = d.Items
	b = d.Keys	'Cleaning up from menu stuff to get logfile
	logfile = b(iChoice-1)
	b = Split(logfile,")")
	logfile = Trim(b(1))
	sADSPath = a(iChoice-1)
	d.RemoveAll		'Clear the dictionary
	searchDom sADSPath
	On Error goto 0
End Sub

Sub GetCounts(strType)
	Dim strCommand
	On Error GoTo 0
	irc=0
	Select Case strType
		Case "2000Servers"
			strQuery = 	"(&(&(objectCategory=Computer)(OperatingSystem=*Server*)(operatingSystemVersion=5.0*)))"
			strTxt = "Windows 2000 Server Accounts: "
		
		Case "Active2000"
			strQuery = "(&(objectCategory=Computer)(OperatingSystem=*Server*)(pwdLastSet>=" & _
			dtmDateValue(iComputerAgeAgo) & ")(!(userAccountControl:1.2.840.113556.1.4.803:=2))(operatingSystemVersion=5.0*))"
			strTxt = "Windows 2000 Server (not disabled, password changed in last " & iComputerMax &" days): "
			
		Case "2008Servers"
			strQuery = 	"(&(&(objectCategory=Computer)(OperatingSystem=*Server*)(operatingSystemVersion=6.1*)))"
			strTxt = "Windows 2008 Server Accounts: "
			
		Case "Active2008"
			strQuery = "(&(&(objectCategory=computer)(!(userAccountControl:1.2.840.113556.1.4.803:=2))" & _
			"(OperatingSystem=*Server*)(operatingSystemVersion=6.1*)(pwdLastSet>=" & dtmDateValue(iComputerAgeAgo) & ")))"		
			strTxt = "Windows 2008 Server (not disabled, password changed in last " & iComputerMax &" days): "

		Case "2003Servers"
			strQuery = 	"(&(&(objectCategory=Computer)(OperatingSystem=*Server*)(operatingSystemVersion=5.2*)))"
			strTxt = "Windows 2003 Server Accounts: "

		Case "Active2003"
			strQuery = "(&(&(objectCategory=computer)(!(userAccountControl:1.2.840.113556.1.4.803:=2))" & _
			"(OperatingSystem=*Server*)(operatingSystemVersion=5.2*)(pwdLastSet>=" & dtmDateValue(iComputerAgeAgo) & ")))"		
			strTxt = "Windows 2003 Server (not disabled, password changed in last " & iComputerMax &" days): "

		Case "AllServers"
			strQuery = 	"(&(&(objectCategory=Computer)(OperatingSystem=*Server*)))"
			strTxt = "Total Server Accounts: "

		Case "AllWKS"
			strQuery = 	"(&(&(objectCategory=Computer)(OperatingSystem=*Professional*)))"
			strTxt = "Total Workstation Accounts: "

		Case "W2KPro"
			strQuery = "(&(&(sAMAccountType=805306369)(objectCategory=computer)(operatingSystemVersion=5.0*)(operatingSystem=*Professional*)))"
			strTxt = "Windows 2000 Workstation Accounts: "

		Case "Win7"
			strQuery = "(&(&(sAMAccountType=805306369)(objectCategory=computer)(operatingSystemVersion=7.0*)(operatingSystem=*Professional*)))"
			strTxt = "Windows 7 Workstation Accounts: "

		Case "ActiveWin7"
			strQuery = "(&(&(objectCategory=computer)(!(userAccountControl:1.2.840.113556.1.4.803:=2))" & _
			"(OperatingSystem=*Professional*)(operatingSystemVersion=7.0*)(pwdLastSet>=" & dtmDateValue(iComputerAgeAgo) & ")))"		
			strTxt = "Windows 7 Workstations (not disabled, password changed in last " & iComputerMax &" days): "
			
		Case "Vista"
			strQuery = "(&(&(sAMAccountType=805306369)(objectCategory=computer)(operatingSystemVersion=6.0*)(operatingSystem=*Professional*)))"
			strTxt = "Windows Vista Workstation Accounts: "
	
		Case "ActiveVista"
			strQuery = "(&(&(objectCategory=computer)(!(userAccountControl:1.2.840.113556.1.4.803:=2))" & _
			"(OperatingSystem=*Professional*)(operatingSystemVersion=6.0*)(pwdLastSet>=" & dtmDateValue(iComputerAgeAgo) & ")))"		
			strTxt = "Windows Vista Workstations (not disabled, password changed in last " & iComputerMax &" days): "			
			
		Case "XPPro"
			strQuery = "(&(&(sAMAccountType=805306369)(objectCategory=computer)(operatingSystemVersion=5.1*)(operatingSystem=*Professional*)))"
			strTxt = "Windows XP Workstation Accounts: "
			
		Case "ActiveW2KPro"
			'Whew!
			strQuery = "(&(&(objectCategory=computer)(!(userAccountControl:1.2.840.113556.1.4.803:=2))" & _
			"(OperatingSystem=*Professional*)(operatingSystemVersion=5.0*)(pwdLastSet>=" & dtmDateValue(iComputerAgeAgo) & ")))"		
			strTxt = "Windows 2000 Workstations (not disabled, password changed in last " & iComputerMax &" days): "		
		
		Case "ActiveXPPro"
			'Whew!
			strQuery = "(&(&(objectCategory=computer)(!(userAccountControl:1.2.840.113556.1.4.803:=2))" & _
			"(OperatingSystem=*Professional*)(operatingSystemVersion=5.1*)(pwdLastSet>=" & dtmDateValue(iComputerAgeAgo) & ")))"
			strTxt = "Windows XP Workstations (not disabled, password changed in last " & iComputerMax &" days): "		
		
		Case "NT4"
			strQuery = "(&(objectCategory=Computer)(OperatingSystemVersion=4.*))"
			strTxt = "Windows NT 4 Servers and Workstation Accounts: "
			
		Case "Users"
			strQuery = "(&(objectCategory=Person)(objectClass=User))"
			strTxt = "All User Accounts: "
			
		Case "NotService"
			strQuery = "(&(&(&(objectCategory=person)(objectClass=user)" &_
			"(!(userAccountControl:1.2.840.113556.1.4.803:=2))" & _
			"(!(userAccountControl:1.2.840.113556.1.4.803:=65536)))))"
			strTxt = "User Accounts (not disabled, not set to password never expires): "
			
		Case "ActiveNotService"
			strQuery = "(&(&(&(objectCategory=person)(objectClass=user)" &_
			"(!(userAccountControl:1.2.840.113556.1.4.803:=2))" & _
			"(!(userAccountControl:1.2.840.113556.1.4.803:=65536)(pwdLastSet>=" & dtmDateValue(iUserDaysAgo) & ")))))"
			strTxt = "Active User Accounts (Password changed within last " &iUserMax &" days , not disabled, not set to password never expires): "

		Case "MailEnabled"
			'whew again!
			strQuery = "(&(&(&(&(objectCategory=person)(objectClass=user)" &_
			"(mailNickName=*)" & _
			"(!(userAccountControl:1.2.840.113556.1.4.803:=2))" & _
			"(!(userAccountControl:1.2.840.113556.1.4.803:=65536)(pwdLastSet>=" & dtmDateValue(iUserDaysAgo) & "))))))"
			strTxt = "Active Mail Enabled User Accounts (Password changed within last " &iUserMax &" days not disabled, not set to password never expires): "
	End Select

	Set oConn = CreateObject("ADODB.Connection")
	Set oCommand =   CreateObject("ADODB.Command")
	oConn.Provider = "ADsDSOObject"
	oConn.Open "Active Directory Provider"
	Set oCommand.ActiveConnection = oConn
	oCommand.Properties("TimeOut") = 240
	oCommand.Properties("Page Size") = 250
	oCommand.Properties("Searchscope") = ADS_SCOPE_SUBTREE

	strCommand = "<LDAP://"&strOUDomain &"/" & sADSPath &">;" & strQuery & ";Name" 
	'WScript.Echo strCommand 
	oCommand.CommandText = strCommand
	     
	Set objRecordSet = oCommand.Execute
	
	If Not objRecordSet.eof Then 	'lets run from array to avoid keeping db open
	        rsArray = objRecordSet.GetRows() 
	        iRC = UBound(rsArray,2) + 1 
	End If 
	
	objRecordSet.Close

	EchoAndLog strTxt & iRC

End Sub 


Function  dtmDateValue(strDate)
	'Based on Muller's script at http://www.rlmueller.net/Programs/DateToInteger8.txt
    Dim lngBias, lngBiasKey,K, dtmAdjusted, lngSeconds
	If vartype(dtmDateValue) <> 7 Then 'if not a date format..
	 	dtmDateValue = CDate(strDate)
	End If
	
	' Obtain local Time Zone bias from machine registry.
	Set wshShell = CreateObject("Wscript.Shell")
	lngBiasKey = wshShell.RegRead("HKLM\System\CurrentControlSet\Control\" _
	  & "TimeZoneInformation\ActiveTimeBias")
	If UCase(TypeName(lngBiasKey)) = "LONG" Then
	  lngBias = lngBiasKey
	ElseIf UCase(TypeName(lngBiasKey)) = "VARIANT()" Then
	  lngBias = 0
	  For k = 0 To UBound(lngBiasKey)
	    lngBias = lngBias + (lngBiasKey(k) * 256^k)
	  Next
	End If
	
	' Convert datetime value to UTC.
	dtmAdjusted = DateAdd("n", lngBias, strDate)
	
	' Find number of seconds since 1/1/1601.
	lngSeconds = DateDiff("s", #1/1/1601#, dtmAdjusted)
	
	' Convert the number of seconds to a string
	' and convert to 100-nanosecond intervals.
	dtmDateValue = CStr(lngSeconds) & "0000000"
End Function 

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 strArgs, i
	
		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 IsCScript()
    If (InStr(UCase(WScript.FullName), "CSCRIPT") <> 0) Then
        IsCScript = True
    Else
        IsCScript = False
    End If
End Function

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