Ping function makes the whole excel table slow/unr

Question

I have a function that pings computers from an excel list and gets the ping value of them.

While the script was running, the excel was completely unresponsive. I could fix this with DoEvents, this made it a bit more responsive.

However, the problem starts when the function gets to an offline computer. While it waits for the response of the offline PC, Excel freezes again and the script does not jump to the next PC until it gets the "timeout" from the actual one.

As the default ping timeout value is 4000ms, if I have 100 computers in my list, and 50 of them are turned off, that means I have to wait an extra 3,3 minutes for the script to finish, and also blocks the entire Excel, making it unusable for the duration.

My question is, if is there any way to make this faster or more responsive or smarter?

The actual code:

Function:

Function sPing(sHost) As String

    Dim oPing As Object, oRetStatus As Object

    Set oPing = GetObject("winmgmts:{impersonationLevel=impersonate}").ExecQuery _
      ("select * from Win32_PingStatus where address = '" & sHost & "'")
 DoEvents
    For Each oRetStatus In oPing
        DoEvents
            If IsNull(oRetStatus.StatusCode) Or oRetStatus.StatusCode <> 0 Then
            sPing = "timeout" 'oRetStatus.StatusCode <- error code
        Else
            sPing = sPing & vbTab & oRetStatus.ResponseTime
        End If
    Next
End Function

Main:

Sub pingall_Click()
Dim c As Range
Dim p As String
Dim actives As String

actives = ActiveSheet.Name

StopCode = False

Application.EnableCancelKey = xlErrorHandler
On Error GoTo ErrH:
DoEvents
    For Each c In Sheets(actives).UsedRange.Cells
        If StopCode = True Then
            Exit For
        End If
    DoEvents
        If  Left(c, 7) = "172.21." Then
        p = sPing(c)
        [...]
        End If
    Next c
End Sub

Answer 1

As already noted in the comments, to prevent this from blocking after each call, you need to invoke your pings asynchronously from your function. The way I would approach this would be to delegate your sPing(sHost) function to a VBScript that you create on the fly in a temp folder. The script would look something like this, and it takes the IP address as a command line argument and outputs the result to a file:

Dim args, ping, status
Set ping = GetObject("winmgmts:{impersonationLevel=impersonate}").ExecQuery _
      ("select * from Win32_PingStatus where address = '" & Wscript.Arguments(0) & "'")
Dim result
For Each status In ping
    If IsNull(status.StatusCode) Or status.StatusCode <> 0 Then
        result = "timeout"
    Else
        result = result & vbTab & status.ResponseTime
    End If
Next
Dim fso, file
Set fso = CreateObject("Scripting.FileSystemObject")
Set file = fso.CreateTextFile(Wscript.Arguments(0), True)
file.Write result
file.Close

You can create a Sub to write this to a path something like this:

Private Sub WriteScript(path As String)
    Dim handle As Integer
    handle = FreeFile
    Open path & ScriptName For Output As #handle
    Print #handle, _
        "Dim args, ping, status" & vbCrLf & _
        "Set ping = GetObject(""winmgmts:{impersonationLevel=impersonate}"").ExecQuery _" & vbCrLf & _
        "      (""select * from Win32_PingStatus where address = '"" & Wscript.Arguments(0) & ""'"")" & vbCrLf & _
        "Dim result" & vbCrLf & _
        "For Each status In ping" & vbCrLf & _
        "    If IsNull(status.StatusCode) Or status.StatusCode <> 0 Then" & vbCrLf & _
        "        result = ""timeout""" & vbCrLf & _
        "    Else" & vbCrLf & _
        "        result = result & vbTab & status.ResponseTime" & vbCrLf & _
        "    End If" & vbCrLf & _
        "Next" & vbCrLf & _
        "Dim fso, file" & vbCrLf & _
        "Set fso = CreateObject(""Scripting.FileSystemObject"")" & vbCrLf & _
        "Set file = fso.CreateTextFile(Wscript.Arguments(0), True)" & vbCrLf & _
        "file.Write result" & vbCrLf & _
        "file.Close"
    Close #handle
End Sub

After that, it's pretty straightforward - create a new directory in the user's temp directory, plop the script in there, and then use the Shell command to run each ping in its own process. Wait for the length of your timeout, then read the results from the files:

Private Const TempDir = "\PingResults\"
Private Const ScriptName As String = "ping.vbs"
'Important - set this to the time in seconds of your ping timeout.
Private Const Timeout = 4

Sub pingall_Click()
    Dim sheet As Worksheet
    Set sheet = ActiveSheet

    Dim path As String
    'Create a temp folder to use.
    path = Environ("Temp") & TempDir
    MkDir path
    'Write your script to the temp folder.
    WriteScript path

    Dim results As Dictionary
    Set results = New Dictionary

    Dim index As Long
    Dim ip As Variant
    Dim command As String
    For index = 1 To sheet.UsedRange.Rows.Count
        ip = sheet.Cells(index, 1)
        If Len(ip) >= 7 Then
            If Left$(ip, 1) = "172.21." Then
                'Cache the row it was in.
                results.Add ip, index
                'Shell the script.
                command = "wscript " & path & "ping.vbs " & ip
                Shell command, vbNormalFocus
            End If
        End If
    Next index

    Dim completed As Double
    completed = Timer + Timeout
    'Wait for the timeout.
    Do While Timer < completed
        DoEvents
    Loop

    Dim handle As String, ping As String, result As String
    'Loop through the resulting files and update the sheet.
    For Each ip In results.Keys
        result = Dir$(path & ip)
        If Len(result) <> 0 Then
            handle = FreeFile
            Open path & ip For Input As #handle
            ping = Input$(LOF(handle), handle)
            Close #handle
            Kill path & ip
        Else
            ping = "timeout"
        End If
        sheet.Cells(results(ip), 2) = ping
    Next ip

    'Clean up.
    Kill path & "*"
    RmDir path
End Sub

Note that this has exactly zero error handling for the file operations, and doesn't respond to your StopCode flag. It should give the basic gist of it though. Also note that if you need to allow the user to cancel it, you won't be able to remove the temp directory because it will still be in use. If that is the case, only create it if it isn't already there and don't remove it when you're done.

Answer 2

You might be able to implement something like this, but I haven't tried it with multiple servers

• if your network is fast you can reduce the timeout to 500 ms or less:

.

Public Function serverOk(ByVal dbSrvrNameStr As String) As Boolean

    Const PINGS         As Byte = 1
    Const PING_TIME_OUT As Byte = 500
    Const PING_LOCATION As String = "C:\Windows\System32\"

    Dim commandResult As Long, serverIsActive As Boolean

    commandResult = 1
    serverIsActive = False

    If Len(dbSrvrNameStr) > 0 Then

        Err.Clear

        With CreateObject("WScript.Shell")
            commandResult = .Run("%comspec% /c " & PING_LOCATION & "ping.exe -n " & PINGS & " -w " & PING_TIME_OUT & " " & dbSrvrNameStr & " | find ""TTL="" > nul 2>&1", 0, True)
            commandResult = .Run("%comspec% " & PING_LOCATION & "/c ping.exe -n " & PINGS & " -w " & PING_TIME_OUT & " " & dbSrvrNameStr, 0, True)
            serverIsActive = (commandResult = 0)
        End With

        If serverIsActive And Err.Number = 0 Then
            '"DB Server - valid, Ping response: " & commandResult
        Else
            '"Cannot connect to DB Server, Error: " & Err.Description & ", Ping response: " & commandResult
        End If
        Err.Clear
    End If

    serverOk = serverIsActive
End Function

.

Link to "Run Method (Windows Script Host)" from Microsoft:

https://msdn.microsoft.com/en-us/library/d5fk67ky(VS.85).aspx

The 3rd parameter of this command can be overlooked: "bWaitOnReturn" - allows you to execute it asynchronously from VBA