'PCDomainLogonHistory.vbs
'Alan dot Kaplan at VA dot Gov 7-13-2011
'This script queries a list of computers and get a list of domain users that have logged on from WMI
'Using WMI for this is slow.
Option Explicit
Dim strFilePath: strFilePath = ""
Dim i, arrComputers
Dim retVal
dim strIP, strPingStatus
dim wshShell: Set wshShell = WScript.CreateObject("WScript.Shell")
Dim strComputer, message

If (Not IsCScript()) Then 		'If not CScript, re-run with cscript...
	dim quote: quote=chr(34)
    Dim strCmdLine, Argument
    
    strCmdLine = WScript.Path & "\cscript.exe //NOLOGO " & quote & WScript.scriptFullName & Quote
    
    If Wscript.Arguments.Count > 0 Then
        For Each Argument in Wscript.Arguments
            strCmdLine = strCmdLine & space(1) & quote & Argument & quote
        Next 
    End If
    
    oWShell.Run strCmdLine,1,False
    WScript.Quit            	'...and stop running as WScript    
End If

if wscript.arguments.count = 0 Then 
	message = "This script gets a list of domain accounts which have logged onto a list of computers.  This is a slow process." & _
	vbCrLf & VbCrLf & "Excel is supported, but not required. This relies on WMI, and admin rights are required."
	retval = MsgBox(message,vbInformation + vbOKCancel,"Welcome")
	If retval = vbCancel Then WScript.Quit
	strFilePath = ExcelOpenDialog("Choose a text file containing computer names", "Text Files (*.txt),*.txt",strFilePath ) 
Else
	strFilePath = Wsccript.arguments(0)
End If 

'setup log
Const ForAppend = 8
Dim fso,logfile, appendout, logName 
logName = Left(WScript.ScriptName,Len(Wscript.ScriptName)-3)& "XLS"
logfile = wshShell.ExpandEnvironmentStrings("%userprofile%") & "\desktop\" & logName
Set fso = CreateObject("Scripting.FileSystemObject")
If fso.FileExists(logfile) Then fso.DeleteFile logfile, True 

set appendout = fso.OpenTextFile(logfile, ForAppend, True)
echoandlog "Computername	Logon Name	Full Name	Description	Disabled	Errors"

arrComputers = ArrayFromList(strFilePath)

For i = 0 To UBound(arrComputers)
	If Len(arrComputers(i)) > 0 Then 
		strcomputer =  arrComputers(i)
		if PingReply(strComputer) Then 
			WMIQuery strComputer
		Else
			EchoAndLog strComputer & String(5,vbTab) & "Failed. " & strPingStatus
		End If 
	End If 
Next

appendout.Close

SaveAsExcel logfile

MsgBox "Script Complete.  The logfile is " & logfile, vbInformation + vbOKOnly,"Done"

'========== Functions And Sub ==================
Function WMIQuery(strComputer)
    Dim oWMI, oWMIObjSet, oWMIUserAcct
    On Error Resume Next 
    Set oWMI = GetObject("winmgmts:\\" & strComputer & "\root\CIMV2")
    oWMI.Security_.ImpersonationLevel = 3

    If Err <> 0 Then 
    	EchoAndLog strComputer & String(5,vbTab) & "Failed. " & Err.Description
    	Exit Function 
    End If 

    Set oWMIObjSet = oWMI.ExecQuery("ASSOCIATORS OF {Win32_ComputerSystem.Name='"& strComputer & "'} WHERE AssocClass=Win32_SystemUsers ResultClass=Win32_UserAccount")
    If oWMIObjSet.Count Then
        For Each oWMIUserAcct In oWMIObjSet
        	If oWMIUserAcct.LocalAccount = False Then 
	            EchoAndLog strComputer & vbTab & oWMIUserAcct.Caption & vbTab & oWMIUserAcct.FullName & vbTab  & oWMIUserAcct.Description & _
	             vbTab  & oWMIUserAcct.Disabled
            End If 
        Next
    Else
       EchoAndLog strComputer & String(5,vbTab) & "No network users have logged on."
    End If
    
    Set oWMIObjSet = Nothing
    Set oWMI = Nothing
End Function

Function ExcelOpenDialog( sPrompt, sFilter, strDefaultFile ) 
	'Based on code by Michael Hardt 
   	'http://www.softimage.com/community/xsi/discuss/archives/xsi.archive.0111/msg00066.htm
	Dim oExcelApp 
	On Error Resume Next 
	Set oExcelApp = CreateObject("Excel.Application") 
	If Err =  0 Then 
	Dim sFile 
   	sFile = oExcelApp.GetOpenFilename ( sFilter, , sPrompt) 	   	
	'Cancel or no file name? 
	   	If sFile <> False Then 
	      	ExcelOpenDialog = sFile 
	   	Else 
	   		oExcelApp.Quit
	     	Wscript.quit
	   	End If 
	 Else
	 	Err.Clear
		ExcelOpenDialog = InputBox(sPrompt,"Open what file",strDefaultFile)
	 End If 
	On Error GoTo 0
End Function 

Function ArrayFromList(strFilePath)
	Dim fso, f, strAll
	Set fso = CreateObject("Scripting.FileSystemObject")
	Const ForReading = 1 
	Set f = fso.OpenTextFile(strFilePath,ForReading) 
	strAll = f.ReadAll
	ArrayFromList = Split(strAll,VbCrLf)
End Function 

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

	
Sub SaveAsExcel(strFileName)
	Const xlnormal = -4143 
	Const xlAscending = 1
	Const xlDescending = 2
	Const xlYes = 1
	Const xlSortValues = 1

	Dim fso, oXL, objRange, objRange2
	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
		WScript.echo "Saving log as tab delimited text, please wait"
		fso.MoveFile strFileName, Replace(strFileName,".xls",".txt")
		Exit Sub
	Else
		WScript.echo "Saving log as Excel file, please wait"
	End If 

	'oXL.Visible = True
	oXL.DisplayAlerts=False ' don't display overwrite prompt.
	oXL.Workbooks.Open(strFileName)
	Set objRange = oXL.Worksheets(1).UsedRange
	Set objRange2 = oXL.Range("A2")
	objRange.Sort objRange2, xlAscending,,,,,, xlYes
	objRange.EntireColumn.Autofit()

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


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

 
Function PingReply(strcomputer) 
	strIP = "Not Available"
	Dim objScriptExec, strPingResults
	Dim objRE, match, matches, strOut 

	'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)
	strOut = lcase(objScriptExec.StdOut.Readall)

	If InStr(strOut,"could not find host") Then
		PingReply = False
		strPingStatus = "No Host Record"
		Exit Function
	End If  
	
	If InStr(strOut,"unreachable") Then 
		PingReply = False
		strPingStatus = "Unreachable"
	End If  
	
	If  InStr(strOut,"bytes=") = 0 Then 
		PingReply = False
		strPingStatus= "Offline"
	Else
		PingReply = True
		strPingStatus = "Online"
	End If  
	
	Set matches = objRE.Execute(strOut)   ' Execute search.

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