Невозможно изменить тайм-аут ping в списке Excel VBA IP-адрес

Question

Ниже приведен код, содержащий список IP-адресов в листе Excel и возвращает время ответа и TTL. В зависимости от количества IP-адресов тайм-аут может складываться очень быстро и долго ждать. Есть ли способ добавить пользовательский тайм-аут в 500 мс?

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 есть свойство, называемое «Тайм-аут» (в миллисекундах), который, вероятно, может быть изменен.

Попробуйте изменить запрос

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

Это выглядит по умолчанию 1000 миллисекунд