ping&send$mail

'********************************************************************************
'Script to ping servers and send an email
'to a group of people if it is not reachable
'7/26/12 Jeff Berndsen
'********************************************************************************

Option Explicit
On Error Resume Next

Dim strServerName, oFSO, WSHShell, strServerFile, PINGFlag, i, ServerPingFlag
Dim strLogFileName, strLogFolderName, strLogPath, objLogFolderName
Dim objLogFileName, objLogTextFile, strMyDate
Const ForAppending = 8
Public strMailTo, strSMTP, strSubject, strBody, strSMTPUserName, strSMTPPassword, strSMTPPort

'SMTP Settings
strSMTPUserName = ""
strSMTPPassword = ""
strSMTP = ""
strSMTPPort = ""
strMailTo = ""

Set oFSO = CreateObject("Scripting.FileSystemObject")
Set WSHShell = CreateObject("WScript.Shell")

'Keep looping back through the script so that it stays running
i = 0
Do While i = 0
Set strServerFile = oFSO.OpenTextFile("ServerList.txt")

'Convert date to a more readable format
strMyDate = Date
strMyDate = Replace(strMyDate,"/","_")

'Log settings
strLogFolderName = ""
strLogFileName = "\" & strMyDate & ".log"
strLogPath = strLogFolderName & strLogFileName

'Check that the log folder exists
If oFSO.FolderExists(strlogFolderName) Then
        Set objLogFolderName = oFSO.GetFolder(strLogFolderName)
Else
        Set objLogFolderName = oFSO.CreateFolder(strLogFolderName)
End If

'Check that the log file exists
If oFSO.FileExists(strLogFolderName & strLogFileName) Then
        Set objLogFolderName = oFSO.GetFolder(strLogFolderName)
Else
        Set objLogFileName = oFSO.CreateTextFile(strLogFolderName & strLogFileName, True)
        objLogFileName.Close 'Log file has to be closed before it can be appended to
End If
               
'Open the log file for appending
Set objLogTextFile = oFSO.OpenTextFile(strLogPath, ForAppending, True)

objLogTextFile.WriteLine(Now & vbCrLf)

Do While Not (strServerFile.AtEndOfStream)
strServerName = strServerFile.ReadLine
        If ServerPing(strServerName) Then
                ServerPingFlag = "Online"
                'Ping was successful
                Logger strServerName, ServerPingFlag
        Else
                'Ping was not successful
                ServerPingFlag = "***Offline***"
                EmailAdmins strServerName
                Logger strServerName, ServerPingFlag
        End If
Loop

objLogTextFile.WriteLine("----------------------------------------------")
WScript.Sleep 300000
Loop

'********************************************************************************
'ServerPing Function
'Ping the server and if available return true, otherwise false
'********************************************************************************
Function ServerPing(strServerName)
        Set WSHShell = CreateObject("WScript.Shell")
        PINGFlag = Not CBool(WSHShell.Run("ping -n 1 " & strServerName, 0, True))
        If PINGFlag = True Then
                'Ping was successful
                ServerPing = True
        Else
                'Ping not successful
                ServerPing = False
        End If
End Function

'********************************************************************************
'EmailAdmins Sub-Routine
'Send email to the admins
'********************************************************************************
Sub EmailAdmins (strServerName)
Dim oMsg, oFlds, oConf
Const cdoSendUsingPort = 2
Set oMsg = CreateObject("CDO.Message")
Set oConf = CreateObject("CDO.Configuration")
Set oFlds = oConf.Fields
strBody = strServerName & " is not able to be pinged on " & Now

With oFlds
        .Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = cdoSendUsingPort
        .Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = strSMTP
        .Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1
        .Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = strSMTPUserName
        .Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = strSMTPPassword
        .Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = strSMTPPort
        .Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = True
        .Item("http://schemas.microsoft.com/cdo/configuration/smtpconnectiontimeout") = 60
        .Update
End With

With oMsg
        Set .Configuration = oConf
        .Fields("urn:schemas:httpmail:importance").Value = 2 ' Set mail importance to HIGH
        .Fields.Update
        .To = strMailTo
        .From = ""
        .Sender = strSMTPUserName
        .Subject = strServerName & ": Not Pingable"
        .TextBody = strBody
        .Send
End With
       
End Sub
       
'********************************************************************************
'Logger Sub-Routine
'Log successes and failures in pinging
'********************************************************************************
Sub Logger(strServerName, ServerPingFlag)
        objLogTextFile.WriteLine(strServerName & ";" & ServerPingFlag)
End Sub