VBA автономные объекты

Question

У меня есть код ниже, который работает нормально, пошагово пропуская строки для каждого хоста и обновляя лист.

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

Но предположим, у меня 50 устройств и 40 из них не работают.Поскольку это последовательный процесс, мне нужно подождать, пока на этих устройствах не истечет время проверки связи, поэтому один проход может занять много времени.

Могу ли я в VBA создать объект, для которого я могу создать несколько экземпляров, каждый пингуя отдельный хост, а затем выполнить простой цикл, хотя объекты возвращают свойство true / false из них.

Я не знаю, насколько это возможно или как вы работаете с классами в VBA.

Я хочу что-то вроде

set newhostping = newobject(pinger) 
pinger.hostname = x.x.x.x

, чтобы настроить объект, тогда объект будет иметь логику

do
ping host x.x.x.x
if success then outcome = TRUE
if not success then outcome = FALSE
wait 1 second
loop

, поэтому в основном коде я мог бы просто использовать

x = pinger.outcome 

, чтобы узнать текущее состояние хоста, без необходимости ждать завершения текущей операции ping.Это просто вернет результат последней завершенной попытки

Есть ли у кого-нибудь какой-нибудь код или идеи, которыми они могли бы поделиться?

Спасибо

DevilWAH

Answer 1

Вы можете использовать функцию ShellAndWait ниже, чтобы выполнять эти вызовы асинхронно (то есть параллельно). Посмотрите мой пример с простой командой tracert, которая обычно выполняется за несколько секунд. Он открывает одновременно 50 командных окон.

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