麻辣家族討論版版 - Powered by Discuz! Board

標題: 測試IP [打印本頁]

作者: linderlong 時間: 2013-8-26 15:57 標題: 測試IP

下列程式為測試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 時間: 2013-8-26 16:35

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

Public Sub iptest()
MsgBox Ping("10.18.22.5")
End Sub

複製代碼

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

複製代碼

作者: linderlong 時間: 2013-8-28 08:57

本帖最後由 linderlong 於 2013-8-28 08:59 編輯

回復 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 時間: 2013-8-28 09:37

回復 3# linderlong
我連上 Google 約需五秒，如下圖所示：
[attach]15866[/attach]
如以 .1 到 .10 要 45 秒 (偵測外部 IP)，
應是合理範圍。

作者: linderlong 時間: 2013-8-28 10:52

由於要測試的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 時間: 2013-8-28 14:31

本帖最後由 c_c_lai 於 2013-8-28 14:33 編輯

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

Sub Test()
Dim strIP As String, sp As Variant, RetVal
Dim cts As Integer, xi As Integer
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"
sp = Split(strIP, ",")
cts = 0
For xi = 0 To UBound(sp)
cts = cts + 1
' RetVal = Shell("command.com /c Ping -n 1 100.18.22.1 > D:\iptest\1.txt")
RetVal = Shell("command.com /c Ping -n 1 " & sp(xi) & " > " & ThisWorkbook.Path & "\iptest" & cts & ".txt")
工作表1.Cells(cts, 1) = sp(xi)
Next xi
End Sub

複製代碼

作者: linderlong 時間: 2013-8-28 15:00

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

作者: linderlong 時間: 2013-8-28 16:00

回復 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 時間: 2013-8-28 16:14

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

作者: linderlong 時間: 2013-8-29 11:08

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

作者: c_c_lai 時間: 2013-8-29 11:33

回復 10# linderlong

RetVal = Shell("command.com /c Ping -n 1 " & 工作表1.Cells(cts, 1) & " > " & ThisWorkbook.Path & "\iptest" & cts & ".txt")

複製代碼

經實地在 Excel 2010 下測試是無誤的，
請檢查你的執行錯誤點是在哪一段？

作者: c_c_lai 時間: 2013-8-29 12:02

回復 10# linderlong
[attach]15879[/attach]

作者: linderlong 時間: 2013-8-29 13:41

應該不是office的問題，而是作業系統w7，32位元，可以執行，而在64位元系統，則錯在
RetVal = Shell("command.com /c Ping -n 1 " & 工作表1.Cells(cts, 1) & " > " & ThisWorkbook.Path & "\iptest" & cts & ".txt")
這行指令上，不知為何原因？謝謝！

作者: linderlong 時間: 2013-8-30 14:41

本帖最後由 linderlong 於 2013-8-30 14:43 編輯

在w7,64位元,office2007下，逐步執行時，則停在下列指令，
RetVal = Shell("command.com /c Ping -n 1 " & Cells(i, 1) & " > " & ThisWorkbook.Path & "\" & i & ".txt")

按一下說明，出現以下文字，但看不懂，不知如何修正？不知道是不是找到 command.com 這個dos指令？

找不到檔案 (錯誤 53)

所指定的檔案找不到。此錯誤有以下的起因和解決方法：
‧ 陳述式如 Kill、SetAttr 或 Name 等，引用到一個不存在的檔案。
檢查檔案名稱的拼字以及路徑說明。
‧ 欲呼叫動態連結程式庫 (DLL) 中的程序或 Macintosh程式碼資源區，但找不到在 Declare 陳述式的 Lib 子句中所指定程式庫檔案名稱或資源當案名稱。
檢查檔案名稱的拼字以及路徑說明。
‧ 在發展環境中，如果您欲開啟不存在的專案或載入不存在的文字檔案，將發生錯誤。
檢查檔案名稱或專案名稱的拼字以及路徑說明。
詳細資訊，可選取有疑問的項目並按下 F1 (在Windows中) 或 HELP (在Macintosh上)。

作者: c_c_lai 時間: 2013-8-30 15:44

回復 14# linderlong
試著在 WinX 64 位元環境下測試是否OK？
[attach]15902[/attach]

作者: c_c_lai 時間: 2013-8-30 15:47

回復 14# linderlong
你直接將 Debug 畫面完整 Copy 上傳 (需有錯誤點指向)

作者: linderlong 時間: 2013-8-30 15:58

回復 16# c_c_lai
不好意思，公用電腦，目前有人使用，俟空檔時再上傳，謝謝！

作者: linderlong 時間: 2013-8-30 16:11

回復 16# c_c_lai
錯誤說明如下圖；
[attach]15903[/attach]

作者: c_c_lai 時間: 2013-8-30 16:33

回復 18# linderlong
RetVal 上行插入 DoEvents 試試看。

DoEvents
RetVal = Shell("command.com /c Ping -n 1 " & Cells(i, 1) & " > " & ThisWorkbook.Path & "\" & i & ".txt")

複製代碼

作者: linderlong 時間: 2013-8-30 16:59

本帖最後由 linderlong 於 2013-8-30 17:00 編輯

回復 19# c_c_lai
加入doevents還是不行。果然是找不到command指令，不知有無其它替代方法？不好意思，下班了，下星期一才有空再上來。謝謝！

[attach]15904[/attach]

作者: c_c_lai 時間: 2013-8-30 17:09

回復 20# linderlong
這是你網路權限不夠的緣故。
亦即 Users' 的權限不足無法指到 Windows/system32/ 的路徑。

作者: c_c_lai 時間: 2013-8-31 08:14

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

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

Sub TestPing()
Dim xi As Integer
xi = 1
Do
If Cells(xi, 1) <> "" Then
' MsgBox sPing("www.microsoft.com")
' Cells(xi, "C") = sPing("www.google.com")
Cells(xi, "C") = Ping2("www.google.com")
' Cells(xi, "C") = sPing(Cells(xi, 1))
' Cells(xi, "C") = IsConnectible(Cells(xi, 1))
End If
xi = xi + 1
Loop Until Cells(xi, 1) = ""
End Sub

複製代碼

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

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

複製代碼

作者: c_c_lai 時間: 2013-8-31 08:15

回復 20# linderlong

Function sPing(sHost) As String
Dim oPing As Object, oRetStatus As Object
Set oPing = GetObject("winmgmts:{impersonationLevel=impersonate}").ExecQuery _
("select * from Win32_PingStatus where address = '" & sHost & "'")
' The following script illustrates how to use the StatusCode property of the Win32_PingStatus class
' to determine whether a remote computer is responding to the PING command.
' A value of the StatusCode equal to 0 indicates the PING command was successful;
' a non-zero value indicates a failure.
' The reason for the failure can be determined by analyzing returned value,
' which can be one of the following:
' 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
For Each oRetStatus In oPing
If IsNull(oRetStatus.StatusCode) Or oRetStatus.StatusCode <> 0 Then
sPing = "Status code is " & oRetStatus.StatusCode
Else
sPing = oRetStatus.ProtocolAddress & Chr(10) & "Pinging " & sHost & " with " & oRetStatus.BufferSize & " bytes of data:" & Chr(10) & Chr(10)
sPing = sPing & "Time (ms) = " & vbTab & oRetStatus.ResponseTime & Chr(10)
sPing = sPing & "TTL (s) = " & vbTab & vbTab & oRetStatus.ResponseTimeToLive
End If
Next
Set oRetStatus = Nothing
Set oPing = Nothing
End Function

複製代碼

作者: c_c_lai 時間: 2013-8-31 08:16

回復 20# linderlong

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

複製代碼

作者: linderlong 時間: 2013-9-2 14:59

回復 24# c_c_lai
真是搞笑，微軟不知在做什麼，xp及w7，32位元下，均有command指令可用，而在w7，64位元下，則改為cmd，command反而不能用。
因此只要將
RetVal = Shell("command.com /c Ping -n 1 " & Cells(i, 1) & " > " & ThisWorkbook.Path & "\" & i & ".txt")
改為
RetVal = Shell("cmd /c Ping -n 1 " & Cells(i, 1) & " > " & ThisWorkbook.Path & "\" & i & ".txt")
即可正確執行，實在感謝大大的指導，謝謝！:L

歡迎光臨麻辣家族討論版版 (http://forum.twbts.com/)