Attempting to use VBA to Ping within Excel...

[Andy Dawkins]

Hello all,
I am attempting to ping a list of machine names listed within Excel 2003.
So far, I have been able to do this by changing some VBS code I found
online. The problem is that the code opens an existing file, but I would
like to have the results stay in the active spreadsheet.

**Warning** I'm a noobie to VBA code...or any code for that matter, so take
it easy on me.

Here's what I have so far...any help you could provide would be awesome.
Thanks!

Sub Ping()

Dim objExcel
Dim objWorkbook
Dim objWorkSheet
Dim intRow As Integer
Dim Fso
Dim InputFile
Dim srtComputer
Dim objWMIService
Dim colItems
Dim objItem
Dim strComputer As String

Set objExcel = CreateObject("Excel.Application")
objExcel.Visible = True
intRow = 2

Set Fso = CreateObject("Scripting.FileSystemObject")
Set objWorkbook = objExcel.Workbooks.Open("U:\My
Documents\Excel\qry_B_ConfigRoom.xls")
Set InputFile = objWorkbook
Do Until objExcel.Cells(intRow, 1).Value = ""
strComputer = objExcel.Cells(intRow, 1).Value


objExcel.Cells(1, 1).Value = "Machine Name"
objExcel.Cells(1, 2).Value = "IP Address"
objExcel.Cells(1, 3).Value = "Status"

On Error Resume Next
Set objWMIService = GetObject("winmgmts:\\" & strComputer & "\root\CIMV2")
Set colItems = objWMIService.ExecQuery("Select IpAddress From
Win32_NetworkAdapterConfiguration Where IPEnabled=TRUE")
For Each objItem In colItems
If Err.Number <> 0 Then
objExcel.Cells(intRow, 2).Value = ""
objExcel.Cells(intRow, 3).Value = "Off Line"
Err.Clear
Else
objExcel.Cells(intRow, 2).Value = objItem.IPAddress
objExcel.Cells(intRow, 3).Value = "On Line"
End If
Next
intRow = intRow + 1
Loop


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

MsgBox "Done!"

End Sub

 

[Joel]

Try this code.

Sub Ping()

Dim objExcel
Dim objWorkbook
Dim objWorkSheet
Dim intRow As Integer
Dim Fso
Dim InputFile
Dim srtComputer
Dim objWMIService
Dim colItems
Dim objItem
Dim strComputer As String

Set objExcel = ThisWorkbook.Sheets("sheet1")
intRow = 2

Do Until objExcel.Cells(intRow, 1).Value = ""
strComputer = objExcel.Cells(intRow, 1).Value


objExcel.Cells(1, 1).Value = "Machine Name"
objExcel.Cells(1, 2).Value = "IP Address"
objExcel.Cells(1, 3).Value = "Status"

On Error Resume Next
Set objWMIService = GetObject("winmgmts:\\" & strComputer & "\root\CIMV2")
Set colItems = objWMIService.ExecQuery( _
"Select IpAddress From Win32_NetworkAdapterConfiguration Where
IPEnabled=TRUE")
For Each objItem In colItems
If Err.Number <> 0 Then
objExcel.Cells(intRow, 2).Value = ""
objExcel.Cells(intRow, 3).Value = "Off Line"
Err.Clear
Else
objExcel.Cells(intRow, 2).Value = objItem.IPAddress
objExcel.Cells(intRow, 3).Value = "On Line"
End If
Next
intRow = intRow + 1
Loop


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

MsgBox "Done!"

End Sub

 

[Andy Dawkins]

First of all...thanks for your help Joel...you have posted many great answers
on this forum.

Secondly, unfortunately I'm receiving an Run-time error 1004. It seems to
get hung up on the line of code below Loop:

objExcel.Range("A1:c1").Select

Any ideas?

Thanks again...

 

[Joel]

I'm not getting the error. I think the focus my not be on the present
workbook. try adding this line of code

thisworkbook.activate
objExcel.Range("A1:c1").Select

 

[urkec]

I'm not getting the error. I think the focus my not be on the present
workbook. try adding this line of code

The code you posted does not ping remote computers, it tries to connect to a
WMI service on remote computers (strComputer), and if it is available gets
it's IP address. You can use Win32_PingStatus WMI class to ping remote
machines. (It was added for Windows XP, so if you can't use it you can use
Ping command instead.) Your code will work, but it is faster to ping a
computer first, and only if it is available attempt connecting to remote WMI.
Here is some code:

Sub Ping()


Set Machines = Sheets(1).Range("A1", "A10")

For Each Machine In Machines.Cells
Debug.Print Machine
Set objPing = GetObject _
("winmgmts:{impersonationLevel=impersonate}"). _
ExecQuery("select * from Win32_PingStatus " & _
"where address = '" & Machine & "'")
For Each objStatus In objPing
If objStatus.StatusCode = 0 Then
Sheets(1).Cells(Machine.Row, Machine.Column + 1) = _
objStatus.StatusCode & " On Line"
Else
Sheets(1).Cells(Machine.Row, Machine.Column + 1) = _
objStatus.StatusCode & " Off Line"
End If
Next
Next


End Sub


It connects to local WMI service (no computer name in WMI moniker) and gets
ping status for computer names listed in cells A1 - A10. (you can also use IP
address instead of computer name). Possible values for objStatus.StatusCode
are:

0 Success
11001 Buffer Too Small
11002 Destination Net Unreachable
11003 Destination Host Unreachable
11004 Destination Protocol Unreachable
11005 Destination Port Unreachable
11006 No Resources
11007 Bad Option
11008 Hardware Error
11009 Packet Too Big
11010 Request Timed Out
11011 Bad Request
11012 Bad Route
11013 TimeToLive Expired Transit
11014 TimeToLive Expired Reassembly
11015 Parameter Problem
11016 Source Quench
11017 Option Too Big
11018 Bad Destination
11032 Negotiating IPSEC
11050 General Failure

(copied from Win32_PingStatus documentation)

Hope this helps.

 

[Andy Dawkins]

Thank you urkec for your responce. I noticed that you mentioned that
Win32_PingStatus was added for windows XP. If I'm using Windows 2000 what
would I need to do to make it work?

Thank you again for your help!

Andy

 

[urkec]

Thank you urkec for your responce. I noticed that you mentioned that
Win32_PingStatus was added for windows XP. If I'm using Windows 2000 what
would I need to do to make it work?

I found that code here:

http://www.rlmueller.net/PingComputers.htm

You can find other two samples there, one uses WScript.Shell Exec method to
execute the Ping command and then checks it's output to determine if ping was
successful. The other uses WScript.Shell Run method. Both will work with
Windows 2000 (the first sample requires Windows Script Host 5.6, the other
WSH 5.1) If you use WshShell.Exec you won't be able to prevent Command Prompt
appearing on the screen, if you use WshShell.Run you will have to write the
Ping command output to a temporary txt file, so those are not ideal
solutions. The samples are VBScript, VBA the code would look something like
this:


Function Ping2(ByVal Host As String, _
ByVal Pings As Integer, ByVal TimeOut As Integer) As Boolean

Status = CreateObject("WScript.Shell"). _
Exec("%comspec% /c Ping -n " & CStr(Pings) & _
" -w " & CStr(TimeOut) & " " & Host).StdOut.ReadAll

'Debug.Print Status

If InStr(Status, "TTL=") = 0 Then
Ping2 = False
Else
Ping2 = True
End If

End Function


Then you can call Ping2 like this:


Ping2("ANAME", 1, 750)