Ping Multiple Computers with VBScript and Excel

Posted Sunday, July 4, 2010 in Old JamesCMS Posts

Introduction

Yet another ping tool. This one uses WMI's ping function to ping a list of systems quickly. I've also added in a looping function where the script is re-ran after a definable period of time. There is also an update command! It's all in the code section so take a look.

Features

• Grabs a list of computers or IPs from a list (you'll need to create MachineList.txt which one system per line)
• Uses excel to output the results
• Loops the script after a set period of time that can be entered into the excel sheet
• Plays a sound if the machine is off line (remove this to increase speed)

Code:

{{VBScript}}
Dim hostName, colPingResults, objPingResult, strQuery, intRow

Set objExcel = CreateObject("Excel.Application")
objExcel.Visible = True
objExcel.Workbooks.Add

objExcel.Cells(1,1).value = "Computer"
objExcel.Cells(1,2).value = "Results"
objExcel.Cells(9,4).value = "Refresh Period (in seconds):"
objExcel.Cells(10,4).value = "300"
objExcel.Cells(12,4).value = "Command (update or quit):"

While 1=1

If objExcel.Cells(1,1) <> "Computer" Then
	WScript.Quit [0]
End If

On Error Resume Next
intRow = 2

objExcel.Cells(5,4).value = "Last update - " & Now
objExcel.Cells(7,4).value = "Updating..."

Set Fso = CreateObject("Scripting.FileSystemObject")
Set InputFile = fso.openTextFile("MachineList.txt")

Do While Not (InputFile.atEndofStream)

hostName = InputFile.ReadLine

strQuery = "SELECT * FROM Win32_PingStatus WHERE Address = '" & hostName & "'"

Set colPingResults = GetObject("winmgmts://./root/cimv2").ExecQuery( strQuery )

objExcel.Cells(intRow, 1).Value = hostName

For Each objPingResult in colPingResults
	If Not IsObject(objPingResult) Then
		objExcel.Cells(intRow, 2).value = "off line"
		objExcel.Cells(intRow, 2).Range(Char(34) & "A" & intRow & ",B" & intRow & Char(34))
		objExcel.Cells(intRow, 1).Interior.ColorIndex = 3
		objExcel.Cells(intRow, 1).Font.ColorIndex = 2
		objExcel.Cells(intRow, 2).Interior.ColorIndex = 3
		objExcel.Cells(intRow, 2).Font.ColorIndex = 2
		playSound()
	ElseIf objPingResut.StatusCode = 0 Then
		objExcel.Cells(intRow, 2).value = "on line"
		objExcel.Cells(intRow, 1).Interior.ColorIndex = 4
		objExcel.Cells(intRow, 1).Font.ColorIndex = 1
		objExcel.Cells(intRow, 2).Interior.ColorIndex = 4
		objExcel.Cells(intRow, 2).Font.ColorIndex = 1
	Else
		objExcel.Cells(intRow, 2).value = "off line"
		objExcel.Cells(intRow, 2).Range(Char(34) & "A" & intRow & ",B" & intRow & Char(34))
		objExcel.Cells(intRow, 1).Interior.ColorIndex = 3
		objExcel.Cells(intRow, 1).Font.ColorIndex = 2
		objExcel.Cells(intRow, 2).Interior.ColorIndex = 3
		objExcel.Cells(intRow, 2).Font.ColorIndex = 2
		playSound()
	End If

Next

Set colPingResults = Nothing
intRow = intRow + 1
Loop

objExcel.Range("A1:B1").Select
objExcel.Selection.Interior.ColorIndex = 19
objExcel.Selection.Font.ColorIndex = 11
objExcel.Selection.Font.Bold = True
objExcel.Cells.EntireColumn.AutoFit

countdown()

Set FSO = Nothing
Set InputFile = Nothing

Wend

Sub countdown()
If objExcel.Cells(1,1) <> "Computer" Then
	WScript.Quit [0]
End If

On Error Resume Next
Dim count
count = objExcel.Cells(10,4).value

While count > 0
objExcel.Cells(7,4).value = "Next update in " & count & " seconds"
count = count - 1
WScript.Sleep(1000)
If objExcel.Cells(13,4).value = "update" Then
	count = 0
	objExcel.Cells(13,4).value = ""
ElseIf objExcel.Cells(13,4).value = "quit" Then
	objExcel.Cells(15,4).value = "Script has stopped"
	WScript.Quit [0]
End If
Wend

End Sub

Sub playsound()
Dim strCommand, objShell
Set objShell = CreateObject("WScript.Shell")
strCommand = "sndrec32 /play /close " & chr(34) & "C:\windows\media\Windows XP Battery Low.wav" & chr(34)
objShell.Run strCommand, 0, True
End Sub