View Full Version : Ping tester in Excal
joshi868b
12-30-2016, 09:13 PM
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
01-02-2017, 02:35 PM
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
01-05-2017, 02:37 AM
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
Powered by vBulletin® Version 4.2.5 Copyright © 2024 vBulletin Solutions Inc. All rights reserved.