Question

我有下面的代码可以正常工作，逐步ping每个主机并更新工作表。

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台设备已关闭。因为它是顺序的，我必须等待ping在这些设备上超时，因此单次通过可能需要很长时间。

我可以在VBA中创建一个对象，我可以创建多个实例，每个实例ping一个单独的主机，然后通过对象从它们中拉回一个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

VBA自治对象

1 个答案: