処理中にキャッチ/スタックされたときにマクロを前に移動

Question

paping.exeプログラムを使用するマクロを作成して、pingを送信して戻り値を記録することによってデバイスのIPアドレスのリストを循環させます。大部分の時間にマクロが意図どおり動作する間、余分な時間があります。pingコマンドがスタックしているか、つかんでいるように見え、前進を停止します。これにより、私は手動で実行を中断し、プロセスを開始する必要があります。

より広範な視点から、これを処理する方法はありますかruntimeエラーです。私の考えは、デバイスのリストをグループに分け、プログラムが止まったら、マクロに次のグループに進むように伝えることができました。アイドルアイデアの間に、私はこの問題をより雄弁に扱う方法に関するアドバイス、ヒント、アイデアをコミュニティに提供したいと思っていました。私がpingを行っているデバイスのリストは時間の経過とともに増加するように設定されています。

Public Sub getPingStatusCode(IPvalue As String, portValue As String) 

ret = WshShell.Run("C:\Users\*******\paping.exe " & IPvalue & " -p " & portValue & " -c " & pingCount & " -t " & pingTime, 0, True) 'CHANGEEEEEEE 
totalCounter = totalCounter + 1 

Select Case ret 
    Case 0: strResult = "Connected" 
    Case 1: strResult = "Fail" 
    Case 11001: strResult = "Buffer too small" 
    Case 11002: strResult = "Destination net unreachable" 
    Case 11003: strResult = "Destination host unreachable" 
    Case 11004: strResult = "Destination protocol unreachable" 
    Case 11005: strResult = "Destination port unreachable" 
    Case 11006: strResult = "No resources" 
    Case 11007: strResult = "Bad option" 
    Case 11008: strResult = "Hardware error" 
    Case 11009: strResult = "Packet too big" 
    Case 11010: strResult = "Request timed out" 
    Case 11011: strResult = "Bad request" 
    Case 11012: strResult = "Bad route" 
    Case 11013: strResult = "TTL expired transit" 
    Case 11014: strResult = "TTL expired reassembly" 
    Case 11015: strResult = "Parameter problem" 
    Case 11016: strResult = "Source quench" 
    Case 11017: strResult = "Option too big" 
    Case 11018: strResult = "Bad destination" 
    Case 11032: strResult = "Negotiating IPSEC" 
    Case 11050: strResult = "General failure" 
    Case Else: strResult = "Unknown host" 
End Select 

'if statement on return value for bolding and font color 
'and counters 
If ret = 0 Then 'CONNECTED 

    With pingSheet.Cells(i, 4) 
     .Value = strResult 
    End With 
    totalOn = totalOn + 1 
    onOff = 1 

    'set the rawDataSheet value to connected status...assumes that the sheet starts with all rawdata values as "connected" 
    rawDataSheet.Cells(4, i).Value = strResult 

ElseIf ret = 1 Then 'FAILED 

    With pingSheet.Cells(i, 4) 
     .Value = strResult 
     .Font.Color = vbRed 
     .Font.bold = True 
    End With 
    failCounter = failCounter + 1 
    onOff = 0 

    'give RawData sheet a "down since" date value 
    If rawDataSheet.Cells(4, i).Value = "Connected" Then 
     rawDataSheet.Cells(4, i).Value = Now 
    End If 

    '''''''''''''' 
    pdfDeviceDump 

Else 

    With pingSheet.Cells(i, 4) 
     .Value = strResult 
     .Font.Color = vbRed 
     .Font.bold = True 
    End With 
    failCounter = failCounter + 1 
    onOff = 0 

End If 

End Sub 

Answer 1

私が代わりにping.exeを使用していくつかのコードを書いたので、私のマシン上で実行するpaping.exeを取得できませんでした。

原則として、出力をファイルに出力してリダイレクトし、完了したらファイルを後で取り出すことができます。 Windows API呼び出しを使用して、プロセスが完了するのを待ちます。

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 CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long 
Private Declare Function WaitForSingleObject Lib "kernel32.dll" (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long 

Private Const INFINITE = &HFFFF 
Private Const PROCESS_ALL_ACCESS = &H1F0FFF 

Sub TestShellAndRedirectPingToFile() 

    Dim vIPAddresses As Variant 
    vIPAddresses = Array("bbc.co.uk", "wikipedia.org", "cnn.com") 

    Dim dicFilesToPickUp As Scripting.Dictionary 
    Set dicFilesToPickUp = ShellAndRedirectPingToFile(vIPAddresses) 

    Dim vKeyLoop As Variant 
    For Each vKeyLoop In dicFilesToPickUp.Keys 
     Dim lPID As Long 
     lPID = dicFilesToPickUp.Item(vKeyLoop) 

     Dim hProc As Long 
     hProc = OpenProcess(PROCESS_ALL_ACCESS, 0&, lPID) 


     Debug.Print "Waiting on " & vKeyLoop & " (" & lPID & ")" 
     WaitForSingleObject hProc, INFINITE 
     CloseHandle hProc '* be nice and close handles 
    Next 
    Debug.Print "Done! Files ready to read." 


End Sub 

Function ShellAndRedirectPingToFile(ByVal vIPAddresses As Variant) As Scripting.Dictionary 

    Dim dicFilesToPickUp As Scripting.Dictionary 
    Set dicFilesToPickUp = New Scripting.Dictionary 

    Dim sTempFolder As String 
    sTempFolder = Environ$("TEMP") 
    If Right$(sTempFolder, 1) <> "\" Then sTempFolder = sTempFolder & "\" 

    Dim vAddressLoop As Variant 
    For Each vAddressLoop In vIPAddresses 
     Dim sTempFile As String 
     sTempFile = sTempFolder & vAddressLoop & ".txt" 

     Dim sCmd As String 
     sCmd = Environ$("comspec") & " /S /C ping.exe " & vAddressLoop & " > " & sTempFile 

     Dim lPID As Long 
     lPID = VBA.Shell(sCmd) 
     dicFilesToPickUp.Add sTempFile, lPID 
    Next 

    Set ShellAndRedirectPingToFile = dicFilesToPickUp 

End Function