Ping function makes the whole excel table slow/unresponsive

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 co

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.