Unable to change ping timeout in Excel VBA IP list ping

问题

The below code pings a list of IP addresses in an Excel sheet and returns the response time and TTL. Depending on the number of IP addresses the timeout can add up really fast and make for a long wait. Is there any way to add a custom timeout of 500ms?

Sub Ping_Check()
' Based on http://social.technet.microsoft.com/Forums/en-US/ITCG/thread/e59a38e1-eaf0-4b13-af10-fd4be559f50f/
Dim oPing As Object
Dim oRetStatus As Object
Dim xCell As Range
Dim xLast_Row As Long
Dim xWork1 As String

xLast_Row = ActiveSheet.Range("A1").SpecialCells(xlLastCell).Row

Application.ScreenUpdating = False

    For Each xCell In Range("A2:A" & xLast_Row)
        If xCell = "" Then
            xCell.Offset(0, 1) = ""
        Else
            Set oPing = GetObject("winmgmts:{impersonationLevel=impersonate}").ExecQuery("select * from Win32_PingStatus where address = '" & xCell & "'")
            For Each oRetStatus In oPing
                If IsNull(oRetStatus.StatusCode) Or oRetStatus.StatusCode <> 0 Then
                    xCell.Offset(0, 1) = "N/A"
                    '11001   Buffer Too Small
                    '11002   Destination Net Unreachable
                    '11003   Destination Host Unreachable
                    '11004   Destination Protocol Unreachable
                    '11005   Destination Port Unreachable
                    '11006   No Resources
                    '11007   Bad Option
                    '11008   Hardware Error
                    '11009   Packet Too Big
                    '11010   Request Timed Out
                    '11011   Bad Request
                    '11012   Bad Route
                    '11013   TimeToLive Expired Transit
                    '11014   TimeToLive Expired Reassembly
                    '11015   Parameter Problem
                    '11016   Source Quench
                    '11017   Option Too Big
                    '11018   Bad Destination
                    '11032   Negotiating IPSEC
                    '11050   General Failure
                Else
                    xCell.Offset(0, 1) = oRetStatus.ResponseTime & " ms ; " & oRetStatus.ResponseTimeToLive
                End If
            Next
        End If
    Next

Application.ScreenUpdating = True

End Sub

回答1:

According to the MSDN page on Win32_PingStatus there is a property called "Timeout" (in milliseconds) that could probably be changed.

Try changing your query to

"select * from Win32_PingStatus where TimeOut = 500 and address = '" & xCell & "'"

It looks like the default is 1000 milliseconds

来源：https://stackoverflow.com/questions/34682073/unable-to-change-ping-timeout-in-excel-vba-ip-list-ping