excel - 无法更改 Excel VBA IP 列表 ping 中的 ping 超时

Question

下面的代码 ping Excel 工作表中的 IP 地址列表并返回响应时间和 TTL。根据 IP 地址的数量，超时可能会非常快地加起来并导致长时间的等待。有没有办法添加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

Answer 1

根据MSDN page on Win32_PingStatus有一个名为“Timeout”(以毫秒为单位)的属性可能会被更改。

尝试将您的查询更改为

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

看起来默认是 1000 毫秒