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