VBScript content update monitor

This code can be run as a scheduled task, monitoring changes in web content, using the HTML source or an XML RSS feed (or optionally a specified fragment of it). When a change is detected, an email with a link is sent to a specified address.

Please note:
  • The code uses the free Persits.MailSender object, which must be present on the machine running the script. It can be downloaded at www.aspemail.com (you don't have to install the full package, you can just manually extract the files from the installer and register AspEmail.dll with regsvr32.exe).
  • Remember to replace "smtp.yourisp.com" and "updates@yourdomain.com" with the correct hostname for your SMTP server and the correct email addresses.
  • The script should not be used for availability monitoring because HTTP timeouts are ignored, just as anything but an HTTP response code of 200 is also ignored to prevent false update mails due to server outages. If availability monitoring is needed, please use this script instead.
Save the code below as a .vbs file.

Option Explicit

Dim strSMTPServer
Dim strEmailFrom
Dim strEmailTo
Dim strBrowser
Dim blnDebug
strSMTPServer = "smtp.yourisp.com"
strEmailFrom = "updates@yourdomain.com"
strEmailTo = "updates@yourdomain.com"

strBrowser = "Mozilla/5.0 (Windows; U; Windows NT 5.1; en-US; rv:1.8.1.14) Gecko/20071115 Firefox/2.0.0.14"
blnDebug = False

'  Syntax:
'
'  CheckSite "CheckURL", "Link", "Method", "CutBefore", "CutAfter"
'
'  CheckURL - is the URL to the content you want to monitor
'    for changes.
'  Link (optional) - is the link presented in the email.
'    Can be different from the default (CheckURL)
'  Method (optional) - is the compare method. A content
'    match is default. Can be set to "length" to only
'    compare the content length.
'  CutBefore (optional) - is a string to search for. Any
'    data before that string is ignored.
'  CutAfter (optional) - is a string to search for. Any
'    data after that string is ignored.
'
'  Note: The checksite function call needs five parameters
'    even if some of the optional parameters are not used.
'    Use an empty string "" instead as shown in the example.
'
'  Add multiple function calls to monitor different sites.

' ---- Insert sites you want to monitor in this section -------------

CheckSite _
  "http://feedproxy.google.com/dansdata/feed1", _
  "http://www.dansdata.com/", _
  "", _
  "<item>", _
  "</title>"

CheckSite _
  "http://www.alistapart.com/", _
  "", _
  "length", _
  "ishintro", _
  "ishoutro"

' -------------------------------------------------------------------

If FileExist("linkList.txt") Then
  Call SendMail(strEmailFrom, "Website update monitor", strEmailTo, _
    "Latest site updates", ReadFile("linkList.txt"))
  Call DeleteFile("linkList.txt")
End If

Sub WriteFile(strFileName, strContent)
  Const blnOverwr = True
  Const blnAppend = False
  Const blnUnicode = True
  Const blnASCII = False
  Dim objFS
  Dim objFSFile
  Set objFS = CreateObject("Scripting.FileSystemObject")
  Set objFSFile = objFS.CreateTextFile(strFileName, blnOverwr, blnUnicode)
  objFSFile.Write(strContent)
  objFSFile.Close
  Set objFSFile = nothing
  Set objFS = nothing
End Sub

Sub AppendFile(strFileName, strContent)
  Const intRead = 1
  Const intWrite = 2
  Const intAppend = 8
  Const blnCreate = True
  Const blnNoCreate = False
  Const intASCII = 0
  Const intUnicode = -1
  Const intDefault = -2
  Dim objFS
  Dim objTS
  Set objFS = CreateObject("Scripting.FileSystemObject")
  Set objTS = objFS.OpenTextFile(strFileName, intAppend, blnCreate, intASCII)
  objTS.writeLine(strContent)
  objTS.close()
  Set objTS = nothing
  Set objFS = nothing
End Sub

Function ReadFile(strFileName)
  Const intRead = 1
  Const intWrite = 2
  Const intAppend = 8
  Const blnCreate = True
  Const blnNoCreate = False
  Const intASCII = 0
  Const intUnicode = -1
  Const intDefault = -2
  Dim strContents
  Dim objFS
  Dim objTS
  strContents = ""
  Set objFS = CreateObject("Scripting.FileSystemObject")
  If objFS.FileExists(strFilename) Then
    Set objTS = _
      objFS.OpenTextFile(strFileName, intRead, blnNoCreate, intDefault)
    strContents = objTS.ReadAll
    objTS.Close
    Set objTS = nothing
  End If
  Set objFS = nothing
  Readfile = strContents
End Function

Function FileExist(strFileName)
  Dim objFS
  Set objFS = CreateObject("Scripting.FileSystemObject")
  if objFS.FileExists(strFileName) Then
    FileExist = True
  Else
    FileExist = False
  End if
  Set objFS = nothing
End Function

Sub DeleteFile(strFileName)
  Dim objFS
  Set objFS = CreateObject("Scripting.FileSystemObject")
  If objFS.FileExists(strFileName) Then
    objFS.DeleteFile strFileName, true
  End If
  Set objFS = nothing
End Sub

Sub SendMail(strEmailFrom, strFromName, strEmailTo, strSubject, strMessage)
  Dim objEmail
  Set objEmail = CreateObject("Persits.MailSender")
  objEmail.Host = strSMTPServer
  objEmail.From = strEmailFrom
  objEmail.FromName = strFromName
  'objEmail.AddReplyTo(strEmailFrom)
  objEmail.AddAddress(strEmailTo)
  objEmail.isHTML = false
  objEmail.Subject = strSubject
  objEmail.Body = strMessage
  'objEmail.AddAttachment("status.dat")
  objEmail.Send()
  Set objEmail = nothing
End Sub

Function GenerateFileName(strURL)
  Dim objRegExpr
  Dim strIntermediate
  Set objRegExpr = New regexp
  objRegExpr.Global = True
  objRegExpr.Pattern = "[^0-9a-zA-Z]" ' Match anything not alphanumeric
  strIntermediate = objRegExpr.Replace(strURL, "")
  Set objRegExpr = Nothing
  GenerateFileName = strIntermediate & ".txt"
End Function

Function ChopChop(strInput, strCutBefore, strCutAfter)
  If strCutBefore <> "" Then
    If InStr(strInput, strCutBefore) > 0 Then
      strInput = Right(strInput, _
        Len(strInput) - InStr(strInput, strCutBefore) + 1)
    End If
  End If
  If strCutAfter <> "" Then
    If InStr(strInput, strCutAfter) > 0 Then
      strInput = Left(strInput, _
        InStr(strInput, strCutAfter) + Len(strCutAfter) - 1)
        'Use InStrRev instead to search from end to beginning
    End If
  End If
  ChopChop = strInput
End Function

Sub CheckSite(strCheckURL, strClickLink, strType, strCutBefore, strCutAfter)
  Dim objWinHttp
  Dim strContent
  Dim strFile
  Dim strFileContent
  If strClickLink = "" Then
    strClickLink = strCheckURL
  End If
  If strType <> "length" Then
    strType = "content"
  End If
  strFile = GenerateFileName(strCheckURL)
  strFileContent = ReadFile(strFile)
  Set objWinHttp = CreateObject("WinHttp.WinHttpRequest.5.1")
  objWinHttp.SetTimeouts 29000, 29000, 29000, 29000
  objWinHttp.Option(0) = strBrowser
  objWinHttp.Open "GET", strCheckURL
  On Error Resume Next
  objWinHttp.Send()
  If Err.number = 0 Then
    If (objWinHttp.Status = 200) Then
      strContent = objWinHttp.ResponseText
      strContent = ChopChop(strContent, strCutBefore, strCutAfter)
      If (strType = "content" And strContent <> strFileContent) Or _
         (strType = "length" And Len(strContent) <> Len(strFileContent)) _
         Then
        Call AppendFile("linkList.txt", strClickLink)
        Call WriteFile(strFile, strContent)
        If blnDebug = True Then
          Call WriteFile(strFile & ".old", strFileContent)
        End If
      End If
    End If
  End If
  On Error GoTo 0
  Set objWinHttp = Nothing
End Sub
Tags: vbscript
Page last updated 2008-06-15 22:01. Some rights reserved (CC by 3.0)