'DHCPServerList.vbs
'Alan Kaplan, 4/24/2009
'Alan dot Kaplan at va dot gov, or alan at akaplan dot com
'This gets a list of DHCP servers for a domain.
'It pings the servers and verifies they still have valid AD Accounts.

Option Explicit
On Error Resume Next 
Const adVarChar = 200
Const MaxCharacters = 255
Const adFldIsNullable = 32
Const adInteger = 3

Set wshShell = WScript.CreateObject("WScript.Shell")
Dim fso,logfile, appendout
Dim strOnline, bPing
Dim wshShell, oRS
Dim bSearch, retval, message
Dim strDomain, strServer
Dim iSpindex, strSpin
Dim strIP, iServerCount
Dim strNBTName, strADSPath, strADSRoot
Dim oConn, oCommand
Dim oRoot,sDomain

Const ADS_SCOPE_SUBTREE = 2
Set oConn = CreateObject("ADODB.Connection")
Set oCommand =   CreateObject("ADODB.Command")

iSpindex = 0
iServerCount = 0
strOnline = "Not checked"
bPing = False

'tab delimited text opens in Excel
logfile = wshShell.ExpandEnvironmentStrings("%userprofile%") & "\desktop\" & _
	replace(lcase(WScript.ScriptName),".vbs",".xls")

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

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) &  strArgs
	Next
	
	WshShell.Run "CScript.exe " & quote & WScript.ScriptFullName & quote & space(1) & strArgs, 1, true
    WScript.Quit            	'...and stop running as WScript
End If

message = "This script will get a list of DHCP servers.  You can get servers for all domains in AD, or limit the search.  " & _
"Do you want limit the search to a single domain?"

retval = MsgBox(message,vbYesNoCancel,"Limit search")

If retval = vbCancel Then WScript.Quit

If retval = vbNo Then 
	bSearch = False
Else
	bSearch = True
	strDomain = wshShell.ExpandEnvironmentStrings("%USERDNSDOMAIN%")
	strDomain = InputBox("Limit search to what domain?","Domain",strDomain)
	If strDomain = "" Then WScript.Quit
End If 

retval = MsgBox("Ping systems to confirm that they are online?",vbYesNoCancel,"Ping?")
If retval = vbCancel Then WScript.Quit
If retval = vbYes Then bPing = True


'Get the ADsPath for the current domain to search. 
Set oRoot = GetObject("LDAP://rootDSE")
sDomain = ORoot.Get("defaultNamingContext")
GetRoot(sDomain)

If fso.FileExists(logfile) Then fso.DeleteFile logfile,True
set AppendOut = fso.OpenTextFile(logfile, ForAppend, True)
appendout.writeline "DHCP Server FQDN	NETBIOS Name	IP	Online	AD Account Path"

Main

oRS.Sort = "ServerName"
oRS.MoveFirst

message =  oRS.RecordCount & " DHCP servers found " 
If bSearch Then message = message & " in " & strDomain
WScript.Echo message

oConn.Provider = "ADsDSOObject"
oConn.Open "Active Directory Provider"
Set oCommand.ActiveConnection = oConn
'Subtree required because searching from top level
oCommand.Properties("Searchscope") = ADS_SCOPE_SUBTREE 

Do Until oRS.EOF
	strServer =  oRS.Fields.Item("ServerName")
	If bPing Then strOnline = CStr(PingReply(strServer))
	strNBTName = Left(strServer,InStr(strServer,".")-1)
	strADSPath = ComputerOU(strNBTName)
    EchoAndLog strServer  & vbTab & strNBTName & vbTab & oRS.Fields.Item("IP") & vbTab & strOnline & vbTab & strADSPath
	oRS.MoveNext
Loop

oRS.Close
WScript.Echo "Done"

MsgBox "Done, the tab delmited text log file was saved to: " & VbCrLf & logfile,vbOKOnly,"Done"

Sub Main()
	Dim strCommand, objEx, strRetData
	'make sure that NetSH has DHCPMon installed
	strCommand = "NETSH ADD HELPER DHCPMON.DLL"
	Set objEx = WshShell.Exec(strCommand)
	
	'create disconnected recordset -- note the ADOR.  I could have used an array, but 
	'recordsets are easy to sort and are searchable with .filter if needed
	
	Set oRS = CreateObject("ADOR.Recordset")
	oRS.Fields.Append "ServerName", adVarChar, MaxCharacters, adFldIsNullable
	oRS.Fields.Append "IP", adVarChar, MaxCharacters, adFldIsNullable
	oRS.Open
	
	WScript.Echo "Getting list of DHCP servers in " & strADSRoot 
	
	'shell out for info from Netsh. This gives better formatted info than an AD Query.
	strCommand = "netsh dhcp show server"
	Set objEx = WshShell.Exec(strCommand)
	
	WScript.Echo "Validating and formatting the list ....."
	
	While Not objEx.StdOut.AtEndOfStream
		strRetData = objEx.StdOut.Readline()
		CleanLine strRetData
	Wend
End Sub

Sub CleanLine(strText)
	Dim strServerName
	Spin
	strText = ucase(strText)
	Dim tArray
	If instr(strText,"ADDRESS") = 0 Then Exit Sub 
	
	iServerCount = iServerCount +1
	
	tArray = Split(strText,"]")
	
	strServerName =  ucase(mid(tArray(0),instr(tarray(0),"[")+1))
	
	Select Case strServerName
		Case	"" 'if server name is blank, lookup using IP
 			strServerName = mid(tArray(1),instr(tarray(1),"[")+1) 'IP
 			strServerName = GetFQDN(strServerName)
		Case InStr(strServerName,".") = 0 
			strServerName = GetFQDN(strServerName)
	End Select
	
	'to show progress
	If iServercount mod 25 = 0 Then WScript.Echo vbTab & iServerCount & " DHCP servers found in " & strADSRoot 
	
	'Alternative would be .filter after recordset complete
	If bSearch Then 
		If InStr(strServerName,ucase(strDomain)) = 0 Then 	Exit Sub 
	End If 
		
	oRS.AddNew
    oRS("ServerName") = strServerName
    oRS("IP") = mid(tArray(1),instr(tarray(1),"[")+1)
    oRS.Update

End Sub 

Function  GetFQDN(strText)
	dim objEx, data
	
	Set objEx = WshShell.Exec("nslookup " & strText)
	'Works with XP.  Not sure if other OS have same results

	'one line at a time
	While Not objEx.StdOut.AtEndOfStream
		data = objEx.StdOut.Readline()
		
		if instr(data,"Name:") Then 
			GetFQDN = data
			GetFQDN = Trim(Mid(GetFQDN,6)) 'get rid of start of line
			GetFQDN = UCase(GetFQDN)
			Exit Function 
		End If 
	Wend
		GetFQDN = strText & " failed to resolve to a name"
	
	Set objEx = Nothing 
End Function  

Sub Spin() 'just for show
	If iSpinDex >= 4 Then iSpinDex = 0

	Select Case iSpinDex
	Case 0
		strSpin = "\"
	Case 1
		strSpin =  "|"
	Case 2
		strSpin = "/"
	Case 3
		strSpin = "-"
	End Select
	
	WScript.StdOut.Write strSpin
	WScript.Sleep(200)
	WScript.StdOut.Write Chr(8) 'backspace
	iSpindex = iSpinDex + 1
End Sub 


Function PingReply(strcomputer) 
	WScript.Echo " Pinging " & StrComputer
	Dim objScriptExec, strPingResults
	Dim objRE, match, matches

	'RegEx pattern from Bill Stewart
	Set objRE = New RegExp
    objRE.Pattern = " [0-9]{1,3}\.[0-9]{1,3}\.[0-9]{1,3}\.[0-9]{1,3}: "
	
	'Three lines from Steve Cathersalc 
	Set objScriptExec=wshShell.Exec("ping -n 2 -w 1000 " & strComputer)
	Set Matches = objRE.Execute(objScriptExec.StdOut.Readall)   ' Execute search.

	If Matches.count = 1 Then 
	   PingReply = True
	   For Each Match in Matches   ' Iterate Matches collection.
	     strIP = trim(replace(Match.Value,":","")) 'Cleanup
	   Next
	Else
		strIP = ""
		PingReply = False
	End If 
End Function

Function ComputerOU(strComputerName)
	Dim strCommand
	Dim objRS, ComputerPath, oADTmp
	strCommand = "SELECT ADsPath FROM 'GC://" & strADSRoot &"' WHERE objectCategory='Computer' " & _
	         "AND Name   ='" & strComputerName & "'"

	oCommand.CommandText = strCommand
	
	Set objRS = oCommand.Execute
	
	If objRS.BOF And objRS.EOF Then
		ComputerOU = "Not Found"
		Exit Function
	End If 
	
	'note unique answer means no need to loop
	ComputerPath =  objRS.Fields("ADsPath").Value
	set oADTmp = GetObject(ComputerPath)
	ComputerOU = mid(oADTmp.Parent,6)
End Function 

Sub  GetRoot(strPath)	
	'a bit of a kluge.  Continues up until only 2 elements, eg: dc=akaplan,dc=com
	Dim tArray
	tArray = Split(strPath,",")
	If UBound(tArray) = 1 Then 
		strADSRoot = strPath
	Else
		GetRoot(GetParent(strPath))
	End If 
End Sub

Function GetParent(sAdsPath)
	Dim oPOU
	Set oPOU = GetObject("LDAP://"&sADSPath)
	GetParent = Replace(oPOU.parent,"LDAP://","")
End Function 

Sub EchoAndLog (message)
	'Echo output and write to log
	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