Submitted By: Rob Shaw-Fuller

Sends HTTP or HTTPS requests to a list of URLs. The script logs all of its results and sends an alert if any of the URLs do not respond.

Visual Basic
Edit|Remove
OPTION EXPLICIT

Dim fso, WSHShell, objLog
Dim strLogName, strYear, strMonth, strDay, strHour, strMinute
Set fso = CreateObject("Scripting.FileSystemObject")
Set WSHShell = CreateObject("WScript.Shell")

Dim strErrors, intReturn
strErrors = ""

' Do not run the script through CSCRIPT.EXE
If InStr(UCase(WScript.FullName), "WSCRIPT.EXE") = 0 Then
	intReturn = WSHShell.Popup("Interpreter: " & WScript.FullName & vbCRLF &_
     "Please run this script with WScript.exe!", 11, "Webserver Check", vbCritical)
	WScript.Quit
End If

' Initialize all of the time and date variables
strYear = Year(Now)
If Month(Now) < 10 Then
	strMonth = "0" & Month(Now)
Else
	strMonth = Month(Now)
End If
If Day(Now) < 10 Then
	strDay = "0" & Day(Now)
Else
	strDay = Day(Now)
End If
If Hour(Now) < 10 Then
	strHour = "0" & Hour(Now)
Else
	strHour = Hour(Now)
End If
If Minute(Now) < 10 Then
	strMinute = "0" & Minute(Now)
Else
	strMinute = Minute(Now)
End If

' Build the directory path for the log
strLogName = "logs"
If VerifyFolderStatus(strLogName) Then
	strLogName = strLogName & "\" & strYear
	If VerifyFolderStatus(strLogName) Then
		strLogName = strLogName & "\" & strMonth
		If VerifyFolderStatus(strLogName) Then
			strLogName = strLogName & "\" & strDay
			If VerifyFolderStatus(strLogName) Then
				strLogName = strLogName & "\webservercheck" & strHour & strMinute & ".log"
			End If
		End If
	End If
End If

' Start a new log file
If fso.FileExists(strLogName) Then
	fso.DeleteFile strLogName, True
End If
Set objLog = fso.CreateTextFile(strLogName, True)

objLog.WriteLine("Webserver check started: " & Now)
objLog.WriteLine

Call CheckLink("http://www.contoso.com/web/servercheck/images/sign_go.gif", "www-http")
Call CheckLink("https://www.contoso.com/web/servercheck/images/sign_go.gif", "www-http-secure")

objLog.WriteLine("Webserver check completed: " & Now)

objLog.Close

If strErrors <> "" Then
	intReturn = WSHShell.Popup(Now & vbCRLF & strErrors, 90, "Webserver Check", vbCritical + vbSystemModal)
End If


' Begin Functions and Subroutines

Sub CheckLink(strURL, strName)
	' Takes two paramters: the first parameter is a URL to check, and the second parameter is a user-friendly name to identify the URL
	Const lResolve = 15000  ' Wait up to 15 seconds for DNS resolution
	Const lConnect = 60000  ' Wait up to 60 seconds for server connection
	Const lSend = 60000  ' Wait up to 60 seconds to send the request
	Const lReceive = 60000  ' Wait up to 60 seconds before receiving a response
	Dim objHTTP, objStream
	Dim strOutput, tStart, tElapsed, strErrorHex, intError
	If Not VerifyFolderStatus("data") Then
		intReturn = MsgBox("Cannot access data folder!", vbCritical + vbSystemModal, "Webserver Check")
		WScript.Quit
	End If
	strOutput = "data\" & strName & ".gif"
	If fso.FileExists(strOutput) Then
		fso.DeleteFile strOutput, True
	End If
	intReturn = WSHShell.Run("cmd /c ipconfig /flushdns", 0, True)
	Set objHTTP = WScript.CreateObject("MSXML2.ServerXMLHTTP.4.0")
	objHTTP.SetOption 2, 13056  ' Ignore all SSL errors
	objHTTP.SetTimeouts lResolve, lConnect, lSend, lReceive
	tStart = Timer
	objHTTP.Open "GET", strURL, False
	ON ERROR RESUME NEXT
	objHTTP.Send
	If Err.Number <> 0 Then
		strErrorHex = Hex(Err.Number)
		intError = CInt("&H" & Right(strErrorHex, 4))
		objLog.WriteLine(Now)
		objLog.WriteLine("An error occurred contacting " & strURL)
		objLog.WriteLine("Error Code: " & intError)
		objLog.WriteLine("Error Description: " & Err.Description)
		strErrors = strErrors & "Error contacting " & UCase(strName) & ": " & Err.Description
		Err.Clear
		Exit Sub
	End If
	ON ERROR GOTO 0
	Set objStream = CreateObject("ADODB.Stream")
	objStream.Type = 1  ' Binary file
	objStream.Open
	objStream.Write objHTTP.ResponseBody
	objStream.SaveToFile strOutput, 1  ' Will not overwrite files that already exist
	Set objHTTP = Nothing
	Set objStream = Nothing
	tElapsed = 1000 * (Timer - tStart)
	objLog.WriteLine(Now)
	objLog.WriteLine("Saved: " & strURL)
	objLog.WriteLine("To: " & strOutput)
	objLog.WriteLine("Time elapsed: " & tElapsed & "ms")
	If tElapsed > 15000 Then  ' Any response longer than 15 seconds is slow
		objLog.WriteLine("Slow Response Detected!")
		strErrors = strErrors & "Slow response contacting " & UCase(strName) & ": " & tElapsed & "ms" & vbCRLF
	End If
	objLog.WriteLine
End Sub

Function VerifyFolderStatus(fldr)
	ON ERROR RESUME NEXT
	Dim blnExists, objFldr
	If (fso.FolderExists(fldr)) Then
		blnExists = TRUE
	Else
		Set objFldr = fso.CreateFolder(fldr)
		If (fso.FolderExists(fldr)) Then
			blnExists = TRUE
		Else
			blnExists = FALSE
		End If
	End If
	VerifyFolderStatus = blnExists
End Function