Ping tester in Excal

[joshi868b]

my code is follows.But when i execute this code a black command window open and it flicker till the time all devices pings.I want to run it silently

Sub PING()
Application.ScreenUpdating = False
Dim strTarget, strPingResult, strInput, wshShell, wshExec
With Sheets(1)
shlastrow = .Cells(Rows.Count, "B").End(x1up).Row
Set shrange = .Range("B3:B7" & shlastrow)
End With
For Each shCell In shrange
strInput = shCell.Text
If strInput <> "" Then
strTarget = strInput
setwshshell = CreateObject("wscript.shell")
Set wshExec = wshShell.exec("ping -n 2 -w 5 " & strTarget)
strPingResult = LCase(wshExec.stdout.readall)
If InStr(strPingResult, "reply from") Then
shCell.Offset(0, 1).Value = "Reachable"
shCell.Offset(0, 2).Value = "Time"
Else
shCell.Offset(0, 1).Value = "UnReachable"
shCell.Offset(0, 2).Value = "Reachable"
End If
End If
Next shCell
End Sub

[Zack Barresse]

I'm not sure what you're trying to do here, but it seems like you have some IPs incolumn B. I think this will work for you...

Sub testPING2()

Dim shRange As Range
Dim shCell As Range
Dim strTarget As String
Dim strPingResult As String
Dim strInput As String

Dim strCommand As String
Dim strPing As String

Set shRange = Sheets(1).Range("B3", Sheets(1).Cells(Sheets(1).Rows.Count, "B").End(xlUp))

Application.ScreenUpdating = False

For Each shCell In shRange

strCommand = "%ComSpec% /C %SystemRoot%\system32\ping.exe -n 2 -w 5 " & shCell.Value2 & " | " & "%SystemRoot%\system32\find.exe /i " & Chr(34) & "TTL=" & Chr(34)
strPing = RunShell(strCommand)

If strPing = "" Then
shCell.Offset(0, 1).Value = "Unreachable"
Else
shCell.Offset(0, 1).Value = "Reachable"
End If

Next shCell

Application.ScreenUpdating = True

End Sub


Function RunShell(ByVal CommandStringToExecute As String) As String

Dim ShellObject As Object
Dim FSO As Object
Dim TempFileName As Variant
Dim ErrorNumber

Set ShellObject = CreateObject("Wscript.Shell")
Set FSO = CreateObject("Scripting.FileSystemObject")

TempFileName = ShellObject.ExpandEnvironmentStrings("%temp%") & FSO.GetTempName
On Error Resume Next
ShellObject.Run CommandStringToExecute & " > " & TempFileName, 0, True
ErrorNumber = Err.Number
On Error GoTo 0
If ErrorNumber <> 0 Then Exit Function

On Error GoTo RunShell_Error
RunShell = FSO.OpenTextFile(TempFileName, 1).ReadAll
FSO.DeleteFile TempFileName, True
Debug.Print RunShell

Exit Function

RunShell_Error:
FSO.DeleteFile TempFileName, True

End Function

[joshi868b]

This is my code .it pings from a column and display the result in another column.i want it to ping at least 5 times to a device if device is unreachable.and i want it to display the time when it became unreachable instead of current ping time.


Sub Do_ping()


With ActiveWorkbook.Worksheets(1)
n = 0
Row = 2
Do
If .Cells(Row, 1) <> "" Then
If IsConnectible(.Cells(Row, 1), 1, 250) = True Then
n = n + 1
Cells(Row, 1).Interior.Color = RGB(0, 255, 0)
Cells(Row, 1).Font.FontStyle = "bold"
Cells(Row, 1).Font.Size = 14
Cells(Row, 2).Interior.Color = RGB(0, 255, 0)
Cells(Row, 2).Value = Time

Else:

Cells(Row, 1).Interior.Color = RGB(255, 0, 0)
Cells(Row, 2).Value = Time
End If

End If
Row = Row + 1
Loop Until .Cells(Row, 1) = ""
End With
End Sub

Function IsConnectible(sHost, iPings, iTO)
' Returns True or False based on the output from ping.exe
' sHost is a hostname or IP
' iPings is number of ping attempts
' iTO is timeout in milliseconds
' if values are set to "", then defaults below used

Dim nRes
If iPings = "" Then iPings = 1 ' default number of pings
If iTO = "" Then iTO = 550 ' default timeout per ping
With CreateObject("WScript.Shell")
nRes = .Run("%comspec% /c ping.exe -n " & iPings & " -w " & iTO _
& " " & sHost & " | find ""TTL="" > nul 2>&1", 0, True)
End With
IsConnectible = (nRes = 0)

End Function