c_c_lai

回復  c_c_lai
加入doevents還是不行。果然是找不到command指令，不知有無其它替代方法？不好意思，下班了 ...
linderlong 發表於 2013-8-30 16:59

閒閒無事，貼上幾個 Function， 自己看看哪種適用。
1.  測試主程式：

1. Sub TestPing()
   
2.     Dim xi As Integer
   
3.    
   
4.     xi = 1
   
5.     Do
   
6.         If Cells(xi, 1) <> "" Then
   
7.             '  MsgBox sPing("www.microsoft.com")
   
8.             '  Cells(xi, "C") = sPing("www.google.com")
   
9.             Cells(xi, "C") = Ping2("www.google.com")
   
10.             '  Cells(xi, "C") = sPing(Cells(xi, 1))
    
11.             '  Cells(xi, "C") = IsConnectible(Cells(xi, 1))
    
12.         End If
    
13.         xi = xi + 1
    
14.     Loop Until Cells(xi, 1) = ""
    
15. End Sub

複製代碼

以下為程式模組，你可以一一測測看：

1. Private Function Ping2(strAddr As String) As String
   
2.     Dim strTmpFile As String
   
3.    
   
4.     strTmpFile = Environ("TEMP") & "\PingResult.txt"   '  準備建暫存檔在 Windows Temp 目錄下
   
5.     '  建立 WScript 物件 Shell 類別 , 使用 Run 方法 , 呼叫外部指令 Ping ( 並等待其執行結束 )
   
6.     CreateObject("WScript.Shell").Run Environ("COMSPEC") & " /c PING " & strAddr & " > " & strTmpFile, 0, True
   
7.     '  PS : "Ping IP位置 > XX檔案" 這裡是使用 > 來將 Ping 結果寫到檔案裡
   
8.     '  ( 當然也可 Call API CreatePipe 來讀取命令結果 )
   
9.     '  Ping 是一種公用程式，可以驗證一或多個遠端主機連線。
   
10.     '  Ping 指令用 ICMP 回應要求和回應回覆套裝軟體來決定網路上的特殊 IP 系統是否正常運作。
    
11.     '  Ping 對診斷 IP 網路或路由器失敗非常有用。
    
12.     '  Internet Control Message Protocol (ICMP)
    
13.     '  TCP/IP 組件中必要的一種維護通訊協定，可報告錯誤並允許簡易連線。
    
14.     '  Ping 工具用來執行 TCP/IP 疑難排解的 ICMP。
    
15.     '  詳細說明及用法可參考:
    
16.     '  ms-its:%WINDIR%\Help\ntcmds.chm::/ping.htm
    
17.     '  ms-its:%WINDIR%\Help\ntcmds.chm::/ping.htm
    
18.     '  ms-its:%WINDIR%\Help\tcpip.chm::/sag_TCPIP_pro_PingConnect.htm
    
19.     '  ms-its:%WINDIR%\Help\tcpip.chm::/sag_TCPIP_pro_Ping.htm
    
20.     '  建立檔案系統物件,用來開啟暫存文字檔,並讀取內容 ( 取回 Ping的結果 )
    
21.     Ping2 = CreateObject("Scripting.FileSystemObject").OpenTextFile(strTmpFile).ReadAll
    
22.     Ping2 = Replace(Ping2, vbCrLf, "", 1)
    
23.    
    
24.     On Error Resume Next
    
25.     Kill strTmpFile         '  刪除暫存檔
    
26. End Function

複製代碼

c_c_lai

回復 20# linderlong

1. Function sPing(sHost) As String
   
2.     Dim oPing As Object, oRetStatus As Object
   
3.      
   
4.     Set oPing = GetObject("winmgmts:{impersonationLevel=impersonate}").ExecQuery _
   
5.       ("select * from Win32_PingStatus where address = '" & sHost & "'")
   
6.      
   
7.     '  The following script illustrates how to use the StatusCode property of the Win32_PingStatus class
   
8.     '  to determine whether a remote computer is responding to the PING command.
   
9.     '  A value of the StatusCode equal to 0 indicates the PING command was successful;
   
10.     '  a non-zero value indicates a failure.
    
11.     '  The reason for the failure can be determined by analyzing returned value,
    
12.     '  which can be one of the following:
    
13. 
    
14.     '  11001 Buffer Too Small
    
15.     '  11002 Destination Net Unreachable
    
16.     '  11003 Destination Host Unreachable
    
17.     '  11004 Destination Protocol Unreachable
    
18.     '  11005 Destination Port Unreachable
    
19.     '  11006 No Resources
    
20.     '  11007 Bad Option
    
21.     '  11008 Hardware Error
    
22.     '  11009 Packet Too Big
    
23.     '  11010 Request Timed Out
    
24.     '  11011 Bad Request
    
25.     '  11012 Bad Route
    
26.     '  11013 TimeToLive Expired Transit
    
27.     '  11014 TimeToLive Expired Reassembly
    
28.     '  11015 Parameter Problem
    
29.     '  11016 Source Quench
    
30.     '  11017 Option Too Big
    
31.     '  11018 Bad Destination
    
32.     '  11032 Negotiating IPSEC
    
33.     '  11050 General Failure
    
34. 
    
35.     For Each oRetStatus In oPing
    
36.         If IsNull(oRetStatus.StatusCode) Or oRetStatus.StatusCode <> 0 Then
    
37.             sPing = "Status code is " & oRetStatus.StatusCode
    
38.         Else
    
39.             sPing = oRetStatus.ProtocolAddress & Chr(10) & "Pinging " & sHost & " with " & oRetStatus.BufferSize & " bytes of data:" & Chr(10) & Chr(10)
    
40.             sPing = sPing & "Time (ms) = " & vbTab & oRetStatus.ResponseTime & Chr(10)
    
41.             sPing = sPing & "TTL (s) = " & vbTab & vbTab & oRetStatus.ResponseTimeToLive
    
42.         End If
    
43.     Next
    
44.    
    
45.     Set oRetStatus = Nothing
    
46.     Set oPing = Nothing
    
47. End Function

複製代碼

c_c_lai

回復 20# linderlong

1. Function IsConnectible(sHost As String, Optional iPings As Integer = 1, Optional iTO As Integer = 250)
   
2.     '  Returns True or False based on the output from ping.exe
   
3.     '
   
4.     '  Authors: Alex Angelopoulos/Torgeir Bakken
   
5.     '  Modified by: Tom Lavedas
   
6.     '  Works an "all" WSH versions
   
7.     '  sHost is a hostname or IP
   
8.     '  iPings is number of ping attempts
   
9.     '  iTO is timeout in milliseconds
   
10.     '  if values are set to "", then defaults below used
    
11.     '  iPings default number (1) of pings
    
12.     '  iTO default timeout (250) per ping
    
13.     Dim nRes
    
14.    
    
15.     With CreateObject("WScript.Shell")
    
16.         nRes = .Run("%comspec% /c ping.exe -n " & iPings & " -w " & iTO _
    
17.                      & " " & sHost & " | find ""TTL="" > nul 2>&1", 0, True)
    
18.     End With
    
19.    
    
20.     IsConnectible = (nRes = 0)
    
21. End Function

複製代碼