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.
