I wrote a small ducktaped VBA script which pings servers every 15 mins or so. If a server's status is anything other than "Alive", the server and timestamp is written to another worksheet called "Log".
Sub Countup()
Dim CountDown As Date
CountDown = Now + TimeValue("00:00:01")
Application.OnTime CountDown, "Auto_Open"
End Sub
Sub Auto_Open()
Dim count As Range
Set count = Worksheets("Servers").Range("A1:A1")
count.Value = count.Value - TimeSerial(0, 0, 1)
If count <= 0 Then
count = Worksheets("Servers").Range("C1:C1")
Call GetComputerToPing
Call Countup
Exit Sub
End If
Call Countup
End Sub
Public Sub addDataToTable(ByVal strTableName As String, ByVal strData As String, ByVal Col As Integer)
Dim lLastRow As Long
Dim iHeader As Integer
With ActiveSheet.ListObjects(strTableName)
'find the last row of the list
lLastRow = ActiveSheet.ListObjects(strTableName).ListRows.count
'shift from an extra row if list has header
If .Sort.Header = xlYes Then
iHeader = 1
Else
iHeader = 0
End If
End With
'add the data a row after the end of the list
ActiveSheet.Cells(lLastRow + 1 + iHeader, Col).Value = strData
End Sub
'Requires references to Microsoft Scripting Runtime and Windows Script Host Object Model.
'Set these in Tools - References in VB Editor.
Function sPing(sHost) As String
On Error Resume Next
sHost = Trim(sHost)
Dim ipaddress As String
Dim computername As String
Dim Model As String
Dim memory As Long
Dim oPing As Object, oRetStatus As Object
Set oPing = GetObject("winmgmts:{impersonationLevel=impersonate}")
Set oPing = oPing.execquery("select * from win32_pingstatus where address ='" & sHost & "'")
For Each oRetStatus In oPing
If IsNull(oRetStatus.statuscode) Then
sPing = "Dead"
ElseIf oRetStatus.statuscode = 11010 Then
sPing = "Request Timed Out"
ElseIf oRetStatus.statuscode = 11013 Then
sPing = "Destination Host Unreachable"
Else
sPing = "Alive"
End If
Next
Set oPing = Nothing
Set oRetStatus = Nothing
End Function
Sub GetComputerToPing()
Application.DisplayAlerts = False
'On Error Resume Next
Dim applicationobject As Object
Dim i As Integer
i = 3 'row to start checking servers from
Do Until Cells(i, 1) = ""
'If Cells(i, 1) <> "" Then
'If Cells(i, 2) = "Request Timed Out" Or Cells(i, 2) = "" Or Cells(i, 2) = "Dead" Then
Cells(i, 2) = sPing(Cells(i, 1))
Cells(i, 3) = Now()
'log it to Log
If Cells(i, 2).Value <> "Alive" Then
Call copytest(i)
End If
'End If
'End If
i = i + 1
Loop
Set applicationobject = Nothing
End Sub
Function findlast_Row() As Long
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets("Log")
With ws
findlast_Row = .Range("A" & .Rows.count).End(xlUp).Row
End With
End Function
Sub copytest(ByVal intRow As Integer)
'screens for last row in log sheet
iLastRow = findlast_Row() + 1
Worksheets("Log").Range("A" & CStr(iLastRow) & ":E" & CStr(iLastRow)).Value = Worksheets("Servers").Range("A" & CStr(intRow) & ":E" & CStr(intRow)).Value
End Sub
Is there another way (or better way) to do the countdown timer?