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

我在VBA可以创建一个对象，我可以创造的，每个ping一台独立的主机乘实例，然后简单的循环，虽然对象拉回从他们真/假财产。

我不知道该怎么可能，这是或你如何应对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