VBA autonomous objects - vba

Question

I have the code below which works fine, steps through the rows pinging each host and updating the sheet.
Sub Do_ping()
Set output = ActiveWorkbook.Worksheets(1)
With ActiveWorkbook.Worksheets(1)
Set pinger = CreateObject("WScript.Shell")
pings = 1
pingend = "FALSE"
output.Cells(2, 4) = pings
output.Cells(2, 5) = pingend
Do
Row = 2
Do
If .Cells(Row, 1) <> "" Then
result = pinger.Run("%comspec% /c ping.exe -n 1 -w 250 " _
& output.Cells(Row, 1).Value & " | find ""TTL="" > nul 2>&1", 0, True)
If (result = 0) = True Then
result = "TRUE"
Else
result = "FALSE"
End If
' result = IsConnectible(.Cells(Row, 1), 1, 1000)
output.Cells(Row, 2) = result
End If
Row = Row + 1
Loop Until .Cells(Row, 1) = ""
waitTime = 1
Start = Timer
While Timer < Start + waitTime
DoEvents
Wend
output.Cells(2, 4) = pings
output.Cells(2, 5) = pingend
pings = pings + 1
Loop Until pingend = "TRUE"
End With
End Sub
But suppose I have 50 devices and 40 of them are down. Because it is sequential I have to wait for the pings to time out on these devices and so a single pass can take a long time.
Can I in VBA create an object that I can create multiply instances of, each pinging a separate host, and then simple cycle though the objects pulling back a true/false property from them.
I don't know how possible this is or how you deal with classes in VBA.
I want some thing like
set newhostping = newobject(pinger)
pinger.hostname = x.x.x.x
to set up the object then object would have the logic
do
ping host x.x.x.x
if success then outcome = TRUE
if not success then outcome = FALSE
wait 1 second
loop
so back in the main code I could just use
x = pinger.outcome
to give me the current state of the host, with out needing to wait for the current ping operation to complete. It would just return the result of the last completed attempt
Does any one have any code or ideas they could share?
Thank you
DevilWAH

Answer 1

You could use the ShellAndWait function below to run those calls asynchronously (i.e. in parallel). See my example with a simple tracert command which generally takes a few seconds to run. It opens 50 command windows running at the same time.
Option Explicit
Private Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, _
ByVal dwProcessId As Long) As Long
Private Declare Function GetExitCodeProcess Lib "kernel32" (ByVal hProcess As Long, lpExitCode As Long) As Long
Private Const STATUS_PENDING = &H103&
Private Const PROCESS_QUERY_INFORMATION = &H400
Public Sub test()
Dim i As Long
For i = 1 To 50
ShellandWait "tracert www.google.com", vbNormalFocus, 1
Next i
End Sub
Public Function ShellandWait(parProgramName As String, Optional parWindowStyle As VbAppWinStyle = vbMinimizedNoFocus, _
Optional parTimeOutValue As Long = 0) As Boolean
'source: http://www.freevbcode.com/ShowCode.Asp?ID=99
'Time out value in seconds
'Returns true if the program closes before timeout
Dim lInst As Long
Dim lStart As Long
Dim lTimeToQuit As Long
Dim sExeName As String
Dim lProcessId As Long
Dim lExitCode As Long
Dim bPastMidnight As Boolean
On Error GoTo ErrorHandler
lStart = CLng(Timer)
sExeName = parProgramName
'Deal with timeout being reset at Midnight
If parTimeOutValue > 0 Then
If lStart + parTimeOutValue < 86400 Then
lTimeToQuit = lStart + parTimeOutValue
Else
lTimeToQuit = (lStart - 86400) + parTimeOutValue
bPastMidnight = True
End If
End If
lInst = Shell(sExeName, parWindowStyle)
lProcessId = OpenProcess(PROCESS_QUERY_INFORMATION, False, lInst)
Do
Call GetExitCodeProcess(lProcessId, lExitCode)
DoEvents
If parTimeOutValue And Timer > lTimeToQuit Then
If bPastMidnight Then
If Timer < lStart Then Exit Do
Else
Exit Do
End If
End If
Loop While lExitCode = STATUS_PENDING
If lExitCode = STATUS_PENDING Then
ShellandWait = False
Else
ShellandWait = True
End If
Exit Function
ErrorHandler:
ShellandWait = False
End Function