Error

<%@ LANGUAGE="VBSCRIPT" %> <% '-------------------------------------------------------------------------------------------------------- ' The Ultimate Guest Book V1.2 ' a simple but highly configurable guest book that merges seamlessly into just about any design. '-------------------------------------------------------------------------------------------------------- '-------------------------------------------------------------------------------------------------------- ' (c) By Hallmann Web Design 2003 ' Do not copy or distribute without written permission from Hallmann Web Design ' hwd@triad.rr.com '-------------------------------------------------------------------------------------------------------- '--------------------------------------------------------------------------------------------------------- ' Do Not Edit Anything Below Here!!!!!-------------------------------------------------------------------- '--------------------------------------------------------------------------------------------------------- ' Variable declaration Dim strConnectionString Dim cnn Dim rstGuest Dim strSQL Dim Error Dim Template Dim Aktion Dim GuestEntry Dim MenuItem Dim Temp Dim HeadLineFont Dim HeadLineColor Dim HeadLineSize Dim SubTitleFont Dim SubTitleColor Dim SubTitleSize Dim MenuFont Dim MentColor Dim MenuSize Dim FontFace1 Dim FontSize1 Dim FontColor1 DIm FontFace2 Dim FontSize2 Dim FontColor2 Dim FontEnd Dim FormStart Dim SubmitButton Dim ClearButton Dim FormEnd Dim PageNumber Dim Navigation_Class if (Class_Navigation <> "") then Navigation_Class = " class=" & chr(34) & Class_Navigation & chr(34) End If FormStart = "" HeadLineFont = "" HeadLineColor = "" HeadLineSize = "" SubTitleFont = "" SubTitleColor = "" SubTitleSize = "" MenuFont = "" MenuColor = "" MenuSize = "" FontFace1 = "" FontColor1 = "" FontSize1 = "" FontFace2 = "" FontColor2 = "" FontSize2 = "" FontEnd = "" '------------------------------------- ' Open the connection to the database '------------------------------------- Sub OpenConnection (Error) Set cnn = Server.CreateObject("ADODB.Connection") On Error Resume Next cnn.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & DataBaseLocation cnn.Open If (Err.Number <> 0) then PrintError Err.Number, "An error has accured when opening the main database" Error = Err.Number Exit Sub End If End Sub '------------------- ' get the recordset '------------------- Sub OpenDataBase(strSQL, CursorType, LockType, Error) OpenConnection Error If (Error <> 0) then Exit Sub Set rstGuest = Server.CreateObject("ADODB.Recordset") rstGuest.Open strSQL, cnn, CursorType, LockType End Sub '-------------------- ' close the database '-------------------- Sub CloseDataBase() rstGuest.Close cnn.Close set cnn = Nothing set rstGuest = Nothing End Sub '------------------------------------------------------------------ ' This function opens a file and returns the contents of the file. '------------------------------------------------------------------ Function ReadFile(txtFile, Error) Dim txtTemp, objFS, objFL Error = 0 On Error Resume Next Set objFS = CreateObject("Scripting.FileSystemObject") On Error Resume Next Set objFL = objFS.OpenTextFile(txtFile) If (Err.Number <> 0) then Error = Err.Number Exit Function End If Do While Not objFL.AtEndOfStream txtTemp = txtTemp & objFL.ReadLine txtTemp = txtTemp & vbCrLf Loop objFL.Close Set objFS = Nothing ReadFile = txtTemp Error = Err.Number End Function '----------------- ' Print ErrorPage '----------------- Sub PrintError(ErrorNumber, Text) %> Error <% Response.Write "Error#: " & ErrorNumber & "
Description: " If (Text <> "") then Response.Write " --> " & Text %>
<% End Sub '-------------------- ' Validate the input '-------------------- Sub CheckIfValid (Error) Dim InputLength Dim WordList Dim i Dim RequiredFieldList Dim ThisIP Error = 0 ' no input at all --> Error = -1 If (Request.Form("txtName") = "") and (Request.Form("txteMail") = "") and (Request.Form("txtFrom") = "") _ and (Request.Form("txtComment") = "") and (Request.Form("txtURL") = "") then Error = -1 Exit Sub End If ' check if input is not oversize InputLength = FieldMaxLength If (Len(Request.Form("txtName")) > InputLength) then Error = -3 Exit Sub End If If (Len(Request.Form("txteMail")) > InputLength) then Error = -4 Exit Sub End If If (Len(Request.Form("txtFrom")) > InputLength) then Error = -5 Exit Sub End If If (Len(Request.Form("txtURL")) > InputLength) then Error = -6 Exit Sub End If InputLength = MaxCommentLength If (Len(Request.Form("txtComment")) > InputLength) then Error = -7 Exit Sub End If ' check if eMail address has @ and . If (((InStr(Request.Form("txteMail"), "@") = 0) or (InStr(Request.Form("txteMail"), ".") = 0))) _ and (Request.Form("txteMail") <> "") then Error = -9 Exit Sub End If ' check if a "banned word" is included If (BadWords <> "") then WordList = Split (BadWords, ",") For i = 0 to UBound(WordList) If (InStr(Request.Form("txtName"),WordList(i)) <> 0) or _ (InStr(Request.Form("txteMail"),WordList(i)) <> 0) or _ (InStr(Request.Form("txtFrom"),WordList(i)) <> 0) or _ (InStr(Request.Form("txtURL"),WordList(i)) <> 0) or _ (InStr(Request.Form("txtComment"),WordList(i)) <> 0) then Error = -8 Exit Sub End If Next End If ' check on required fields If (RequiredFields <> "") then RequiredFieldList = Split (RequiredFields, ",") For i = 0 to UBound(RequiredFieldList) If (Request.Form(RequiredFieldList(i)) = "") then Select Case RequiredFieldList(i) Case "txtName": Error = -10 Case "txtEMail": Error = -11 Case "txtFrom": Error = -12 Case "txtURL": Error = -13 Case "txtComment": Error = -14 End Select Exit Sub End If Next End If ' guest can only sign book so many times If (HowManyEntriesPerPerson > 0) then ThisIP = Request.ServerVariables("REMOTE_ADDR") strSQL = "SELECT * FROM GuestData WHERE IP='" & ThisIP & "' AND Date=#" & Date & "#" OpenDataBase strSQL, adOpenStatic, adLockReadOnly, Error If (Not(rstGuest.EOF)) then rstGuest.MoveFirst If (Error = 0) and (rstGuest.RecordCount >= HowManyEntriesPerPerson) then Error = -15 End If End If CloseDataBase End If End Sub '---------------------------------------- ' creates the "Sign the Guest Book" form '---------------------------------------- Sub CreateInputForm (Error, Name, From, eMail, URL, Comment) Dim GuestEntry MenuItem = "View our Guest Book" Template = Replace(Template, "", MenuFont & MenuColor & MenuSize & "[ " & MenuItem & " ]" & FontEnd) Template = Replace(Template, "", SubTitleFont & SubTitleColor & SubTitleSize & SubTitleSign & FontEnd) GuestEntry = GuestEntry & "" If (RowColor1 = "") then GuestEntry = GuestEntry & VBCrLF & "
" & VBCrLf GuestEntry = GuestEntry & "" & VBCrLf If (RowColor1 = "") then GuestEntry = GuestEntry & "" & VBCrLf GuestEntry = GuestEntry & "" & VBCrLf If (RowColor1 = "") then GuestEntry = GuestEntry & "" & VBCrLf GuestEntry = GuestEntry & "" & VBCrLf If (RowColor1 = "") then GuestEntry = GuestEntry & "" & VBCrLf GuestEntry = GuestEntry & "" & VBCrLf If (RowColor1 = "") then GuestEntry = GuestEntry & "" & VBCrLf GuestEntry = GuestEntry & "" & VBCrLf If (RowColor1 = "") then GuestEntry = GuestEntry & "" GuestEntry = GuestEntry & VBCrLF & "

" Else GuestEntry = GuestEntry & VBCrLF & "
" End If GuestEntry = GuestEntry & VBCrLf & FormStart GuestEntry = GuestEntry & FontFace1 & FontColor1 & FontSize1 & "Name:" & FontEnd GuestEntry = GuestEntry & "	" & " " GuestEntry = GuestEntry & "
" Else GuestEntry = GuestEntry & "
" End If GuestEntry = GuestEntry & FontFace1 & FontColor1 & FontSize1 & "From:" & FontEnd GuestEntry = GuestEntry & "	" & " " GuestEntry = GuestEntry & "
" Else GuestEntry = GuestEntry & "
" End If GuestEntry = GuestEntry & FontFace1 & FontColor1 & FontSize1 & "eMail:" & FontEnd GuestEntry = GuestEntry & "	" & " " GuestEntry = GuestEntry & "
" Else GuestEntry = GuestEntry & "
" End If GuestEntry = GuestEntry & FontFace1 & FontColor1 & FontSize1 & "Web Site: ( include http:// )" & FontEnd GuestEntry = GuestEntry & "	" & " " GuestEntry = GuestEntry & "
" Else GuestEntry = GuestEntry & "
" End If GuestEntry = GuestEntry & FontFace1 & FontColor1 & FontSize1 & "Comment:" & FontEnd GuestEntry = GuestEntry & "	" & "" & Comment & "" GuestEntry = GuestEntry & "
" Else GuestEntry = GuestEntry & "
" End If If (Error <> 0) then GuestEntry = GuestEntry & FontFace1 & FontCOlor1 & FontSize1 Select Case Error Case -1: GuestEntry = GuestEntry & "Error: All fields are empty." Case -3: GuestEntry = GuestEntry & "Error: The Name field contains too many characters." Case -4: GuestEntry = GuestEntry & "Error: The eMail field contains too many characters." Case -5: GuestEntry = GuestEntry & "Error: The From field contains too many characters." Case -6: GuestEntry = GuestEntry & "Error: The Web Site field contains too many characters." Case -7: GuestEntry = GuestEntry & "Error: The Comment field contains too many characters." Case -8: GuestEntry = GuestEntry & "Error: One of the inputs contains a prohibited word." Case -9: GuestEntry = GuestEntry & "Error: eMail address is invalid." Case -10: GuestEntry = GuestEntry & "Error: The Name field is empty." Case -11: GuestEntry = GuestEntry & "Error: The eMail field is empty." Case -12: GuestEntry = GuestEntry & "Error: The From field is empty." Case -13: GuestEntry = GuestEntry & "Error: The URL field is empty." Case -14: GuestEntry = GuestEntry & "Error: The Comment field is empty." Case -15: GuestEntry = GuestEntry & "Error: You can only sign in " & HowManyEntriesPerPerson & " times each day." End Select GuestEntry = GuestEntry & FontEnd & VBCrLf & " " End If GuestEntry = GuestEntry & "" GuestEntry = GuestEntry & SubmitButton & " " & ClearButton & FormEnd GuestEntry = GuestEntry & "

" & VBCrLf Template = Replace(Template, "", GuestEntry) End Sub '----------------------- ' shows the information '----------------------- Sub ShowInfo () Dim GuestEntry Dim NumberOfRecords NumberOfRecords = rstGuest.RecordCount GuestEntry = MenuFont & MenuColor & MenuSize & NumberOfRecords & " have signed in." GuestEntry = GuestEntry & "
Displaying page " & PageNumber & " of " & rstGuest.PageCount & FontEnd Template = Replace(Template, "", GuestEntry) End Sub '--------------------------- ' show the navigation links '--------------------------- Sub ShowNavigation () Dim GuestEntry Dim NextPage Dim PreviousPage Dim i Dim PageCounter Dim FromPage Dim ToPage If (PageNumber = 0) then PageNumber = 1 NextPage = PageNumber PreviousPage = PageNumber PreviousPage = PreviousPage - 1 If (PreviousPage < 1) then PreviousPage = 0 NextPage = NextPage + 1 If (NextPage > rstGuest.PageCount) then NextPage = 0 FromPage = 1 ToPage = 10 If (PageNumber < 10) then FromPage = 1 ToPage = 10 else If (rstGuest.PageCount - 9 < PageNumber) then FromPage = rstGuest.PageCount - 9 ToPage = rstGuest.PageCount Else FromPage = PageNumber - 4 ToPage = PageNumber + 5 End If End If If (ToPage > rstGuest.PageCount) then ToPage = rstGuest.PageCount GuestEntry = GuestEntry & MenuFont & MenuColor & MenuSize If (PreviousPage <> 0) or (NextPage <> 0) then If (PreviousPage <> 0) then GuestEntry = GuestEntry & "[ " & "First" & "" & " ] " if (BreakUpNavigation = "YES") then GuestEntry = GuestEntry & "
" GuestEntry = GuestEntry & "[ " & "<<Previous" & "" & " ] " if (BreakUpNavigation = "YES") then GuestEntry = GuestEntry & "
" Else GuestEntry = GuestEntry & "[ " & "First ] " if (BreakUpNavigation = "YES") then GuestEntry = GuestEntry & "
" GuestEntry = GuestEntry & "[ " & "<<Previous ] " if (BreakUpNavigation = "YES") then GuestEntry = GuestEntry & "
" End If End If ' do the page numbers If (FromPage <> ToPage) then For i = FromPage to ToPage if (i <> PageNumber ) then GuestEntry = GuestEntry & "" & i & " " Else GuestEntry = GuestEntry & i & " " End If Next End If If (PreviousPage <> 0) or (NextPage <> 0) then if (BreakUpNavigation = "YES") then GuestEntry = GuestEntry & "
" If (NextPage <> 0) then GuestEntry = GuestEntry & " [ " & "Next>>" & "" & " ] " if (BreakUpNavigation = "YES") then GuestEntry = GuestEntry & "
" GuestEntry = GuestEntry & " [ " & "Last" & "" & " ] " if (BreakUpNavigation = "YES") then GuestEntry = GuestEntry & "
" Else GuestEntry = GuestEntry & " [ Next>> ] " if (BreakUpNavigation = "YES") then GuestEntry = GuestEntry & "
" GuestEntry = GuestEntry & " [ Last ] " if (BreakUpNavigation = "YES") then GuestEntry = GuestEntry & "
" End If End If GuestEntry = GuestEntry & FontEnd Template = Replace(Template, "", GuestEntry) End Sub '----------------------------- ' print the "view entry page" '----------------------------- Sub ListEntries () Dim GuestEntry Dim Entries MenuItem = "Sign our Guest Book

" Template = Replace(Template, "", MenuFont & MenuColor & MenuSize & "[ " & MenuItem & " ]" & FontEnd) Template = Replace(Template, "", SubTitleFont & SubTitleColor & SubTitleSize & SubTitleView & FontEnd) strSQL = "SELECT * FROM GuestData WHERE Visible = True ORDER BY Date DESC, id DESC" OpenDataBase strSQL, adOpenStatic, adLockReadOnly, Error If (Error = 0) then if (Not(rstGuest.EOF)) then rstGuest.MoveFirst rstGuest.PageSize = PageSize If (PageNumber <> 0) then rstGuest.AbsolutePage = PageNumber ELse PageNumber = 1 End If if (Not(rstGuest.EOF)) then For Entries = 1 to PageSize If (Not(rstGuest.EOF)) then GuestEntry = GuestEntry & "" If (RowColor1 = "") then GuestEntry = GuestEntry & VBCrLF & "" & VBCrLf & "" & VBCrLf & "

" Else GuestEntry = GuestEntry & VBCrLF & "

" End If GuestEntry = GuestEntry & VBCrLf If (rstGuest("Name") <> "") then GuestEntry = GuestEntry & FontFace1 & FontColor1 & FontSize1 & rstGuest("Date") & " - " & rstGuest("Time") & FontEnd & "
" & VBCrLf If (rstGuest("From") <> "") then GuestEntry = GuestEntry & FontFace1 & FontColor1 & FontSize1 & rstGuest("Name") & " from " & rstGuest("From") & " had the following comment:

" & FontEnd & VBCrLf Else GuestEntry = GuestEntry & FontFace1 & FontColor1 & FontSize1 & rstGuest("Name") & " had the following comment:
" & FontEnd & VBCrLf End If End If If (RowColor2 = "") then GuestEntry = GuestEntry & VBCrLF & "

" Else GuestEntry = GuestEntry & VBCrLF & "

" End If GuestEntry=GuestEntry & "

" If (rstGuest("Comment") <> "") then GuestEntry = GuestEntry & FontFace2 & FontColor2 & FontSize2 & rstGuest("Comment") & "

" & FontEnd & VBCrLf End If If (rstGuest("eMail") <> "") then GuestEntry = GuestEntry & FontFace2 & FontColor2 & FontSize2 & "eMail" & vfCRLf & "
" & FontEnd & VBCrLf End If If (rstGuest("URL") = "") then GuestEntry = GuestEntry & "
" If (rstGuest("URL") <> "") then GuestEntry = GuestEntry & FontFace2 & FontColor2 & FontSize2 & "Web Site" & vfCRLf & "

" & FontEnd & VBCrLf End If GuestEntry = GuestEntry & "

" GuestEntry = GuestEntry & VBCrLF & "

" & VBCrLf if (Not(rstGuest.EOF)) then rstGuest.MoveNext End If Next Else GuestEntry = "No entries found" End If Template = Replace(Template, "", GuestEntry) ShowInfo ShowNavigation CloseDataBase End If End Sub '------------------------------------ ' update the database with new entry '------------------------------------ Sub UpdateDataBase (Error) Dim Temp rstGuest.AddNew on Error Resume Next rstGuest("Name") = Request.Form("txtName") rstGuest("From") = Request.Form("txtFrom") rstGuest("eMail") = Request.Form("txteMail") rstGuest("URL") = Request.Form("txtURL") If ((InStr(rstGuest("URL"), "http://") = 0 ) and (InStr(rstGuest("URL"), "HTTP://") = 0 )) and (rstGuest("URL") <> "") then rstGuest("URL") = "http://" & rstGuest("URL") End If Temp = Request.Form("txtComment") if (Temp <> "") then Temp = Replace (Temp, VBCrLf, "
") rstGuest("Comment") = Temp rstGuest("Date") = Date rstGuest("Time") = Time rstGuest("IP") = Request.ServerVariables("REMOTE_ADDR") If (rstGuest("IP") = "") then rstGuest("IP") = "Unknown IP" If (WaitForApproval = "NO") then rstGuest("Visible") = True Else rstGuest("Visible") = False End If rstGuest.Update If (Err.Number<>0) then PrintError Err.Number, "An error has accured when updating the main database" Error = Err.Number End If End Sub '------------------- ' Send eMail object '------------------- Sub SendMail (FromEMail, SendToEMail, Subject, Body) Const CdoBodyFormatHTML = 0 ' Body property is HTML Const CdoBodyFormatText = 1 ' Body property is plain text (default) Const CdoMailFormatMime = 0 ' NewMail object is in MIME format Const CdoMailFormatText = 1 ' NewMail object is plain text (default) Const CdoLow = 0 ' Low importance Const CdoNormal = 1 ' Normal importance (default) Const CdoHigh = 2 ' High importance Dim objSendMail Set objSendMail = CreateObject("CDONTS.NewMail") objSendMail.From = FromEMail objSendMail.To = SendToEMail objSendMail.Subject = Subject objSendMail.Body = Body objSendMail.BodyFormat = CdoBodyFormatText objSendMail.MailFormat = CdoMailFormatMime objSendMail.Importance = CdoNormal objSendMail.Send Set objSendMail = Nothing End Sub '---------------------------- ' Send the eMail to the owner '---------------------------- Sub SendEMailToOwner () Dim FromEMail Dim objSendMail Dim Body Dim Subject Dim SendToEMail If (SendEMail <> "YES") then exit sub SendToEMail = SendEMailTo FromEMail = SendEMailTo 'FromEMail = Request.Form("txtEMail") 'If (FromEMail = "") then FromEMail = SendEMailTo Subject = EMailSubject Body = "Name: " & Request.Form("txtName") & VBCrLF & _ "eMail: " & Request.Form("txtEMail") & VBCrLF & _ "From: " & Request.Form("txtFrom") & VBCrLF & _ "URL: " & Request.Form("txtURL") & VBCrLF & _ "Comment: " & Request.Form("txtComment") & VBCrLF If (WaitForApproval = "YES") then Body = Body & VBCrLf & "Waiting for approval. Not yet posted!" SendMail FromEMail, SendToEMail, Subject, Body End Sub '-------------------------------------------------------------------------------------------------------- ' Main part of the program ------------------------------------------------------------------------------ '-------------------------------------------------------------------------------------------------------- '------------------------ ' Load the template file '------------------------ Template = ReadFile (TemplateFileLocation, Error) If (Error<>0) then PrintError Error, "Template file missing" End If '-------------------------------- ' get the "action" or what to do '-------------------------------- Aktion = Request.QueryString("action") If (Aktion="") then Aktion = Request.Form("action") '----------------------------------------------- ' get the page number and convert it to integer '----------------------------------------------- Temp = Request.QueryString("page") If (Temp = "") then Temp = "0" On Error Resume Next PageNumber = CInt (Temp) If (Err.Number <> 0 ) then PageNumber = 1 If (Error = 0) then Template = Replace (Template, "", Title) Template = Replace (Template, "", HeadLineFont & HeadLineColor & HeadLineSize & HeadLine & FontEnd) GuestEntry = "" Select Case Aktion '------------------ ' show the entries '------------------ Case "": ListEntries '--------------------- ' sign the guest book '--------------------- Case "sign": Error = 0 CreateInputForm Error, "", "", "", "", "" '--------------- ' add new entry '--------------- Case "new_entry" CheckIfValid Error If (Error = 0) then strSQL = "SELECT * FROM GuestData WHERE id=0" OpenDataBase strSQL, adOpenStatic, adLockOptimistic, Error If (Error = 0) then UpdateDataBase Error CloseDataBase SendEMailToOwner MenuItem = "Go back to our Guest Book" Template = Replace(Template, "", MenuFont & MenuColor & MenuSize & "[ " & MenuItem & " ]" & FontEnd) Template = Replace(Template, "", SubTitleFont & SubTitleColor & SubTitleSize & SubTitleThanks & FontEnd) End If Else CreateInputForm Error, Request.Form("txtName"), Request.Form("txtFrom"), Request.Form("txteMail"), Request.Form("txtURL"), Request.Form("txtComment") End If Case Else: ListEntries End Select '------------------- ' generate the page '------------------- Response.Write Template End If %>