VBA autonomous objects

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