使用VBA代码Ping IP地址并在Excel中返回结果

Question

我有一些可视基本代码(见下文),用于测试B列(excel电子表格中)的IP连接,并在c栏中显示它是否已连接或无法访问,我只是想知道你是否可以帮助我如果'连接',它希望它是绿色的,任何其他结果都是红色的.

此外,这个脚本可以每小时或每天自动运行吗？

非常感谢,安迪

Function GetPingResult(Host)

   Dim objPing As Object
   Dim objStatus As Object
   Dim strResult 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

Answer 1

您不需要为此编写代码。将所有单元格变为红色，然后添加条件格式以在需要时将其变为绿色。

主页 > 条件格式 > 新规则 > 使用公式...

=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