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.
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
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)