測試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

龍

linderlong

中學生 Rank: 2

帖子: 14
主題: 2
精華: 0
積分: 50
點名: 0
作業系統: XP
軟體版本: office 2003
閱讀權限: 20
性別: 男
來自: 宜蘭
註冊時間: 2013-8-26
最後登錄: 2013-12-19

25^#

發表於 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

龍

TOP

c_c_lai

博士班 Rank: 6 Rank: 6

帖子: 2035
主題: 24
精華: 0
積分: 2031
點名: 0
作業系統: Win7
軟體版本: Office2010
閱讀權限: 100
性別: 男
註冊時間: 2012-3-22
最後登錄: 2024-2-1

24^#

發表於 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

複製代碼

TOP

c_c_lai

博士班 Rank: 6 Rank: 6

帖子: 2035
主題: 24
精華: 0
積分: 2031
點名: 0
作業系統: Win7
軟體版本: Office2010
閱讀權限: 100
性別: 男
註冊時間: 2012-3-22
最後登錄: 2024-2-1

23^#

發表於 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

複製代碼

TOP

c_c_lai

博士班 Rank: 6 Rank: 6

帖子: 2035
主題: 24
精華: 0
積分: 2031
點名: 0
作業系統: Win7
軟體版本: Office2010
閱讀權限: 100
性別: 男
註冊時間: 2012-3-22
最後登錄: 2024-2-1

22^#

發表於 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