无法在Excel VBA IP列表ping中更改ping超时 [英] Unable to change ping timeout in Excel VBA IP list ping

问题描述

以下代码在Excel表单中列出IP地址列表，并返回响应时间和TTL。根据IP地址的数量，超时可以真正加快，并等待很长时间。有没有办法添加500ms的自定义超时？

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

推荐答案

根据 Win32_PingStatus上的MSDN页面有一个名为超时的属性（以毫秒为单位），可以可能会改变

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

尝试将查询更改为

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

它的默认值为1000毫秒

It looks like the default is 1000 milliseconds

这篇关于无法在Excel VBA IP列表ping中更改ping超时的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！