Ping IP-адрес с кодом VBA и результаты возврата в Excel

У меня есть некоторый визуальный базовый код (см. ниже), который проверяет ip-соединение в columb B (из excel spreedsheet) и ставит ли он, что он подключен или недоступен в columb c, мне просто интересно, можете ли вы помочь мне бы хотелось, чтобы он "подключился", если бы какой-либо другой результат был бы красным,

также может ли этот script запускаться автоматически по часовой или ежедневной основе?

Большое спасибо, Andy

    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

Ответ 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

Ответ 2

Чтобы этот запуск выполнялся автоматически через определенные промежутки времени, проверьте эта ссылка.

Вот соответствующий код:

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, поскольку я не могу говорить о том, как долго это будет работать без сбоев, и я бы предположил, что вы могли бы видеть проблемы, если бы вы оставили его в течение нескольких дней за раз.