測試IP

linderlong

下列程式為測試ip的程式，在xp 及OFFICE 2003下可正常執行，但在Windows7及office 2007則無法執行，請問該如何修改？煩請幫忙解答，不勝感激！

Public blnok As Boolean

Public Sub iptest()
Ping ("10.18.22.5")
Cells(1, 1) = blnok
End Sub

Function Ping(strAddr As String) As String
blnok = GetObject("winmgmts:").Get("NetDiagnostics=@").Ping(strAddr, Ping)
End Function

c_c_lai

回復 1# linderlong
試試看用下列 Function 看看：

1. Public Sub iptest()
   
2.     MsgBox Ping("10.18.22.5")
   
3. End Sub

複製代碼

1. Private Function Ping(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.     Ping = CreateObject("Scripting.FileSystemObject").OpenTextFile(strTmpFile).ReadAll
    
22.     Ping = Replace(Ping, vbCrLf, "", 1)
    
23.    
    
24.     On Error Resume Next
    
25.     Kill strTmpFile         '  刪除暫存檔
    
26. End Function

複製代碼

linderlong

回復 2# c_c_lai

感謝大大的指導！已可以使用，但速度上略為緩慢，不知有無方法提升測試的速度，程式如下：
假設a1至a10儲存格內容各為100.18.22.1至100.18.22.10，在我的電腦上執行完一次，要費時45秒，時間上太久了，不知如何縮短時程？謝謝！

Public Sub iptest()
  Columns("B:B").Select
  Selection.ClearContents
  Range("A1").Select
  費時 = Timer
  i = 1
  Do While Cells(i, 1) <> ""
    Cells(i, 2) = Ping(Cells(i, 1))
    i = i + 1
  Loop
  Cells(1, 3) = Timer - 費時
End Sub

Private Function Ping(strAddr As String) As String
    Dim strTmpFile As String
    strTmpFile = Environ("TEMP") & "\PingResult.txt"   '  準備建暫存檔在 Windows Temp 目錄下
    CreateObject("WScript.Shell").Run Environ("COMSPEC") & " /c PING -n 1 " & strAddr & " > " & strTmpFile, 0, True
    Ping = CreateObject("Scripting.FileSystemObject").OpenTextFile(strTmpFile).ReadAll
    Ping = Replace(Ping, vbCrLf, "", 1)
    On Error Resume Next
    Kill strTm
End Function

c_c_lai

回復 3# linderlong
我連上 Google 約需五秒，如下圖所示：

下載 (14.56 KB)

2013-8-28 09:33

如以 .1 到 .10 要 45 秒 (偵測外部 IP)，
應是合理範圍。

linderlong

由於要測試的ip有近百個，如此一來則須要好長的時間。
假若事先在d:\iptest\的目錄下先建好要測試ip的10個批次檔（內容為Ping -n 1 100.18.22.1 > D:\iptest\1.txt），再以下列程式執行測試則僅須不到2秒的時間，但由程式過於冗長，才想請教看看是否有程式簡潔且費時短的方法，謝謝！

Public Sub 工作()
  '測試ip
  費時 = Timer
  列 = 1
  For i = 1 To 10
    批次檔 = "d:\iptest\" & i & ".BAT"
    a = Shell(批次檔, 0)
  Next i
  
  休息 = Timer
  Do While Timer - 休息 < 1
    DoEvents
  Loop
   
  '讀取結果
  For i = 1 To 10
    文字檔 = "d:\iptest\" & i & ".TXT"
    代碼 = FreeFile    ' 取得未使用的檔案代碼。
    Open 文字檔 For Input As #代碼
    cells(i, 2) = Input(120, #代碼)
    Close #代碼    ' 關閉檔案。
  Next i
  cells(1, 3) = Timer - 費時
End Sub

c_c_lai

回復 5# linderlong
你試著用 Shell command 的方式執行看看：

1. Sub Test()
   
2.     Dim strIP As String, sp As Variant, RetVal
   
3.     Dim cts As Integer, xi As Integer
   
4.    
   
5.     strIP = "100.18.22.1,100.18.22.2,100.18.22.3,100.18.22.4,100.18.22.5,100.18.22.6,100.18.22.7,100.18.22.8,100.18.22.9,100.18.22.10"
   
6.    
   
7.     sp = Split(strIP, ",")
   
8.     cts = 0
   
9.     For xi = 0 To UBound(sp)
   
10.         cts = cts + 1
    
11.         '  RetVal = Shell("command.com /c Ping -n 1 100.18.22.1 > D:\iptest\1.txt")
    
12.         RetVal = Shell("command.com /c Ping -n 1 " & sp(xi) & " > " & ThisWorkbook.Path & "\iptest" & cts & ".txt")
    
13.         工作表1.Cells(cts, 1) = sp(xi)
    
14.     Next xi
    
15. End Sub

複製代碼

linderlong

正研究中，十分感激！謝謝！

linderlong

回復 6# c_c_lai
假設a1至a10儲存格內容各為100.18.22.1至100.18.22.10，而將ping的結果依序放在B1至B10的儲存格上，程式如下，已經測試在xp及W7，32位元可以執行，但在W7，64位元系統則在    RetVal = Shell("command.com /c Ping -n 1 " & Cells(i, 1) & " > " & ThisWorkbook.Path & "\" & i & ".txt") 這行指令發生錯誤，請問如何修正？謝謝！

另外不知有無方法直接將 ping 的結果直接寫入B1至B10的儲存格，而不必經由寫入txt檔後，再開啟txt檔將其寫入B1至B10儲存格內。十分感激！

Sub Test()
  Columns("B:C").Select
  Selection.ClearContents
  費時 = Timer
  For i = 1 To 10
    RetVal = Shell("command.com /c Ping -n 1 " & Cells(i, 1) & " > " & ThisWorkbook.Path & "\" & i & ".txt")
  Next i
  
  休息 = Timer
  Do While Timer - 休息 < 2
    DoEvents
  Loop
   
  For i = 1 To 10
    文字檔 = ThisWorkbook.Path & "\" & i & ".TXT"
    代碼 = FreeFile    ' 取得未使用的檔案代碼。
    Open 文字檔 For Input As #代碼
    字長 = LOF(代碼)
    Cells(i, 2) = Input(字長, #代碼)
    Close #代碼    ' 關閉檔案。
  Next i
  Cells(1, 3) = Timer - 費時
End Sub

c_c_lai

回復 8# linderlong
請將 Cells(i, 1) 明確指定 工作表單之歸屬。
譬如： Sheet1.Cells(i, 1) 等。

linderlong

回復 9# c_c_lai
已改為sheet1.cells(i,1)在w7,64位元,office2007下，仍舊無法執行，不知為何原因？謝謝！