使用VBA代碼Ping IP地址，並在Excel中返回結果

我有一些visual basic代碼（見下文），它測試columb B（使用excel spreedsheet）中的ip連接，並將它連接到或不可連接到columb c，我只是想知道你是否可以幫助我，我想如果'連接'它將是綠色任何其他結果將是紅色的，使用VBA代碼Ping IP地址，並在Excel中返回結果

也可以這個腳本每小時或每天自動運行？

非常感謝，安迪

Function GetPingResult(Host) 

    Dim objPing As Object 
    Dim objStatus As Object 
    Dim Result As String 

    Set objPing = GetObject("winmgmts:{impersonationLevel=impersonate}"). _ 
     ExecQuery("Select * from Win32_PingStatus Where Address = '" & Host & "'") 

    For Each objStatus In objPing 
     Select Case objStatus.StatusCode 
     Case 0: strResult = "Connected" 
     Case 11001: strResult = "Buffer too small" 
     Case 11002: strResult = "Destination net unreachable" 
     Case 11003: strResult = "Destination host unreachable" 
     Case 11004: strResult = "Destination protocol unreachable" 
     Case 11005: strResult = "Destination port unreachable" 
     Case 11006: strResult = "No resources" 
     Case 11007: strResult = "Bad option" 
     Case 11008: strResult = "Hardware error" 
     Case 11009: strResult = "Packet too big" 
     Case 11010: strResult = "Request timed out" 
     Case 11011: strResult = "Bad request" 
     Case 11012: strResult = "Bad route" 
     Case 11013: strResult = "Time-To-Live (TTL) expired transit" 
     Case 11014: strResult = "Time-To-Live (TTL) expired reassembly" 
     Case 11015: strResult = "Parameter problem" 
     Case 11016: strResult = "Source quench" 
     Case 11017: strResult = "Option too big" 
     Case 11018: strResult = "Bad destination" 
     Case 11032: strResult = "Negotiating IPSEC" 
     Case 11050: strResult = "General failure" 
     Case Else: strResult = "Unknown host" 
     End Select 
     GetPingResult = strResult 
    Next 

    Set objPing = Nothing 

End Function 

Sub GetIPStatus() 

    Dim Cell As Range 
    Dim ipRng As Range 
    Dim Result As String 
    Dim Wks As Worksheet 


Set Wks = Worksheets("Sheet1") 

Set ipRng = Wks.Range("B3") 
Set RngEnd = Wks.Cells(Rows.Count, ipRng.Column).End(xlUp) 
Set ipRng = IIf(RngEnd.Row < ipRng.Row, ipRng, Wks.Range(ipRng, RngEnd)) 

    For Each Cell In ipRng 
    Result = GetPingResult(Cell) 
    Cell.Offset(0, 1) = Result 
    Next Cell 

End Sub

來源

2014-01-09 Andy

只是想說感謝發佈您的Ping代碼。我發現這非常有用！ –

你不需要的代碼這一點。將所有單元格變爲紅色，然後添加條件格式以使其在需要時變爲綠色。

首頁>條件格式>新建規則>使用公式...

=C2="Connected"

和格式綠色。如果你想這樣做的代碼，你可以在你添加一些行For Each循環

If Result = "Connected" Then 
    Cell.Offset(0,1).Font.Color = vbGreen 
Else 
    Cell.Offset(0,1).Font.Color = vbRed 
End If

來源

2014-01-09 15:07:37

這是非常感謝，是否可以在ping請求開始之前清除單元（coloumb C＆F）（即已連接，請求超時等）並且可以在另一個columb中有ping請求，例如ABCDE F1 - 路由器A 192.168.1.1連接的計算機A 192.168.1.2連接2 - 路由器B 192.168.1.8連接的計算機B 192.168.1.9請求超時很多謝謝，安迪 – Andy

這是一個不同的問題。你應該提出一個新問題。 –

要自動以一定的間隔此運行，檢查出this link.

下面是相關代碼：

Public dTime As Date 
Dim lNum As Long 

Sub RunOnTime() 
    dTime = Now + TimeSerial(0, 0, 10) 'Change this to set your interval 
    Application.OnTime dTime, "RunOnTime" 

    lNum = lNum + 1 
    If lNum = 3 Then 
     Run "CancelOnTime" 'You could probably omit an end time, but I think the program would eventually crash 
    Else 
     MsgBox lNum 
    End If 

End Sub 

Sub CancelOnTime() 
    Application.OnTime dTime, "RunOnTime", , False 
End Sub

我會建議包括一個ThisWorkbook.Save系列，因爲我不能說這個系統將會運行多久而不會崩潰，而且我會想象如果您一次只剩下幾天，就會發現問題。

來源

2014-01-09 17:00:40 thunderblaster

使用VBA代碼Ping IP地址，並在Excel中返回結果

回答

相關問題