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

我无法在我的计算机上运行paping.exe所以我使用ping.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

在捕获/陷入进程

1 个答案: