File: D:/web/common/asp/inc-email-utils - Copy (5).asp
<%
' (SS,15/03/06) Added SetFormAddress, GetBodyFromFile, SetBodyToken, ReplaceStr, changes to SendEmail to use FFromAddress
' (SS,08/12/06) Added SetReponseText, changes to SendEmail to use FResponseText
' (SS,12/12/06) Added Response.CacheControl etc
' Added CheckSecurityCode, SetSecurityType
' Added Form feature (loads of new routines)
' (SS,16/01/07) Changed to ShowForm to get Current Page and added ?p=1 for webstat purposes
' (SS,31/01/07) Improvements mainly to QuickForm
' (SS,05/02/07) Added SetEmailTitle and made live (was inc-email2.asp)
' (SS,04/07/07) Added QF_QUICK_EMAIL_REQUIRED to QuickForm
' (SS,12/07/07) Change to Sub ShowForm to ignore subdirectory
' (SS,19/05/08) Added FFormMainClass to allow main form class to be changed
' Replaced allow occurences of class="form" with FFormMainClass
' (SS,28/05/08) Added AddSecurityHeading, AddSecurityLabel, AddSecurityTextBox, AddSecurityToExistingForm, SecurityOK
' to allow security to be added to existing forms more easily.
' i.e. by renamed from .htm to .asp added include at the start and call to AddSecurityToExistingForm
' also need to add "If SecurityOK Then" before the SendMail call
' (SS,30/10/08) To allow use of these email routines from other utils made the following changes
' Added Sub DoResponseWrite, Sub SetResponseWriteOff, Function GetResponseWriteText, variables FResponseWrite and FResponseWriteText
' This allows the output text to be returned instead of outputting immediately using Response.Write
' Replaced all Response.Writes with DoResponseWrite
' (SS,04/12/08) Moved to separate inc-email-utils.asp (used by inc-email.asp)
' Added parameter to Function SecurityOK
' (SS,17/04/09) Replaced all occurences of NL with NL_ because NL is used by apputils of shopping apps
' and we want to avoid the "Name Redefined" error
' (SS,20/05/09) added new routines: SetSecurityTDAttributes, GetSecurityTDAttributes,
' new globals FSecurityTDHeadingAttributes, FSecurityTDLeftAttributes, FSecurityTDRightAttributes
' changes to AddSecurityHeading, AddSecurityLabel, AddSecurityTextBox
' These allow more fine tuning of table cell attributes for AddSecurityToExistingForm
' without having to add a form class
' (SS,11/05/10) Modified to allow security heading and label to be changed for different language
' New globals FSecurityHeading, FSecurityLabel and sub SetSecurityLanguage
' (SS,21/11/11) Modified SetSecurityType in Sub InitialiseForm to add extra distortion and noise to reduce spam
' (SS,04/09/14) Added Sub AddSecurityControl(AType, AOptions), special version for RWD frameworks ie. bootstrapB
' (SS,01/03/15) Minor change to Sub AddSecurityTextBox and Sub AddSecurityControl, added alt=""security image"" to remove error from W3C validator
' (SS,11/06/19) Change to Sub SendEmail to replaced old DUNDAS and CDO code with new CDO code
' Due to move to new server and deciding against using very old DUNDAS ASP object.
' It was also buggy when content is larger than 1 or 4K.
' Added new functions SendEmailByCDO_ and GetMailServer_
' (SS,05/04/22) Added email address eric.jones.z.mail@gmail.com to function IsSpamEmailAddress
' (SS,22/11/23) In InitialiseForm, changed the length for security code from 4 to 8
' (SS,28/11/23) In InitialiseForm, changed the length for security code from 8 to 6
' (SS,26/05/24) Added added sample@email.tst to Function IsSpamEmailAddress (GSC entry email span was detected) from this address
' VERY IMPORTANT NOTE!!! NOT TO BE TOUCHED BY SOCK (JEETS)'
Dim NL_
NL_ = Chr(13) + Chr(10)
Dim FEmailType, FPlainTextHeadingSpaces, FBody, FTableStyle, FAllowBlankEmailAndTel, FErrorMessage, FEmailer, FSpamLogEnabled
Dim FSubject, FToAddress, FFromAddress, FBccAddress, FBcc2Address, FInternalBccAddress, FThankYouText, FSetEmailTitle
Dim FResponseWrite, FResponseWriteText ' (SS,30/10/08)
Dim FSecurityTDHeadingAttributes, FSecurityTDLeftAttributes, FSecurityTDRightAttributes ' (SS,20/5/09)
Dim FSecurityHeading, FSecurityLabel ' (SS,11/5/10)
' (SS,12/12/06) added following constants, now used in two places
Const EMAIL_NAMES = "Email,EmailAddress,Email_address,Email Address"
Const TELEPHONE_NAMES = "Telephone,Tel,TelNo,Tel No,Tel_no,Phone,PhoneNo,Phone No,Phone_no,PhoneNumber,Phone Number,Phone_number"
' (SS,19/12/06) added following
Const ET_HTML = "HTML", ET_TEXT = "TEXT"
InitialiseEmail ' (SS,13/12/06) moved initialising of variables to new Sub InitialiseEmail
Sub InitialiseEmail
FEmailType = ET_HTML ' can be set to also be set to "PLAIN" '
FPlainTextHeadingSpaces = 0
FTableStyle = _
"td {" &_
"font-family: Verdana, Arial, Helvetica, sans-serif;" &_
"font-size: 10px;" &_
"border-top-width: 1px;" &_
"border-right-width: 1px;" &_
"border-bottom-width: 1px;" &_
"border-left-width: 1px;" &_
"border-bottom-style: solid;" &_
"border-top-color: #CCCCCC;" &_
"border-right-color: #CCCCCC;" &_
"border-bottom-color: #CCCCCC;" &_
"border-left-color: #CCCCCC;" &_
"vertical-align: top;" &_
"}"
FAllowBlankEmailAndTel = False ' (SS,19/9/05)
FErrorMessage = "" ' (SS,19/9/05)
FEmailer = "DUNDAS" ' (SS,1/11/05) can be DUNDAS or CDO
FSpamLogEnabled = True ' (SS,1/11/05)
FSubject = "Web Enquiry" ' (SS,13/12/06)
FToAddress = "" ' (SS,13/12/06)
FBccAddress = "" ' (SS,14/12/06)
FBcc2Address = "" ' (SS,14/12/06)
FInternalBccAddress = "contactforms@itpartnership.com" ' (SS,15/12/06)
FFromAddress = "" ' (SS,15/3/06)
FBody = "" ' (SS,15/3/06)
FThankYouText = "Thank you for your enquiry.<br><br>We will contact you very soon." ' (SS,8/12/06)
FSetEmailTitle = ""
FResponseWrite = True ' (SS,30/10/08)
FResponseWriteText = "" ' (SS,30/10/08)
FSecurityTDHeadingAttributes = "" ' (SS,20/05/09)
FSecurityTDLeftAttributes = "" ' (SS,20/05/09)
FSecurityTDRightAttributes = "" ' (SS,20/05/09)
' (SS,11/5/10) added following to allow these values to be changed for different languages, defaults to English
SetSecurityLanguage("English")
End Sub
Sub SetTableStyle(ATableStyle)
FTableStyle = ATableStyle
End Sub
' (SS,19/9/05)
Sub SetAllowBlankEmailAndTel(AAllowBlankEmailAndTel)
FAllowBlankEmailAndTel = AAllowBlankEmailAndTel
End Sub
' (SS,19/9/05)
Sub SetEmailType(AType, APlainTextHeadingSpaces)
FEmailType = UCase(Trim(AType))
FPlainTextHeadingSpaces = APlainTextHeadingSpaces
End Sub
' (SS,13/12/06)
Sub SetSubject(ASubject)
FSubject = ASubject
End Sub
' (SS,13/12/06)
Sub SetToAddress(AToAddress)
FToAddress = AToAddress
End Sub
' (SS,14/12/06)
Sub SetBccAddress(AAddress)
FBccAddress = AAddress
End Sub
' (SS,14/12/06)
Sub SetBcc2Address(AAddress)
FBcc2Address = AAddress
End Sub
' (SS,15/12/06)
Sub SetInternalBccAddress(AAddress)
FInternalBccAddress = AAddress
End Sub
' (SS,31/1/07)
Sub SetInternalEmailsOff
SetInternalBccAddress ""
End Sub
' (SS,15/3/06)
Sub SetFromAddress(AFromAddress)
FFromAddress = AFromAddress
End Sub
' (SS,1/11/05) use this to set CDO to be used as emailer object
' this can be used if DUNDAS is not available on the server
Sub SetEmailerToCDO
FEmailer = "CDO"
End Sub
Sub SetSpamLogOff
FSpamLogEnabled = False
End Sub
' (SS,8/12/06)
' (SS,31/1/07) was SetReponseText
Sub SetThankYou(AThankYouText)
FThankYouText = AThankYouText
End Sub
' (SS,5/2/07) sets the first line of email
Sub SetEmailTitle(AEmailTitle)
FSetEmailTitle = AEmailTitle
End Sub
' (SS,30/10/08) response write is on by default, use this to turn it off
' use when you want the text not to be output directly but return using GetResponseWriteText
Sub SetResponseWriteOff
FResponseWrite = False
End Sub
' (SS,11/5/10) added following for translation purposes, to allow heading and label to be set in a different language
Sub SetSecurityLanguage(ALanguage)
If ALanguage = "French" Then
FSecurityHeading = "Veuillez saisir le num�ro affich� en rouge ci-dessous."
FSecurityLabel = "Code de s�curit�"
ElseIf ALanguage = "German" Then
FSecurityHeading = "Tippen Sie bitte die unten in Rot angezeigte Nummer ein."
FSecurityLabel = "Sicherheitscode"
Else ' i.e. "English"
FSecurityHeading = "Please type the number shown in red below."
FSecurityLabel = "Security Code"
End If
End Sub
' (SS,30/10/08) returns the response write text
Function GetResponseWriteText
GetResponseWriteText = FResponseWriteText
End Function
Function GetErrorMessage
GetErrorMessage = FErrorMessage
End Function
Sub OpenEmail(AType, APlainTextHeadingSpaces)
FBody = ""
If Trim(AType) <> "" Then ' (SS,13/12/06) added If Trim(AType) <> ""
FEmailType = UCase(Trim(AType))
FPlainTextHeadingSpaces = APlainTextHeadingSpaces
End If
If FEmailType = ET_HTML Then
FBody = FBody & "<html>" & NL_ & "<head>" & NL_
FBody = FBody & "<style type=""text/css"">" & NL_ & "<!--" & FTableStyle & "-->" & NL_ & "</style>" & NL_
FBody = FBody & "</head><body>" & NL_
FBody = FBody & "<table>" & NL_
End If
End Sub
Sub AddToEmail(AHeading, AValue)
If FEmailType = ET_HTML Then
FBody = FBody & NL_ & "<tr>" & NL_
If AHeading = "" Then
FBody = FBody & "<td colspan=""2"">" & AValue & "</td>" & NL_
Else
FBody = FBody & "<td>" & "<b>" & AHeading & "</b>" & "</td>" & NL_
FBody = FBody & "<td>" & "<b>" & Replace(AValue, NL_, "<br>") & " " & "</b>" & "</td>" & NL_
End If
FBody = FBody & "</tr>" & NL_
Else
If AHeading = "" Then
FBody = FBody & AValue & NL_
Else
If Len(AHeading) >= FPlainTextHeadingSpaces Then
FBody = FBody & AHeading
Else
FBody = FBody & Left(AHeading & Space(FPlainTextHeadingSpaces), FPlainTextHeadingSpaces)
End If
FBody = FBody & ": " & AValue & NL_
End If
End If
End Sub
' (SS,19/12/06) replaces Newlines in email body with given value
' used by SendSmsEmail
Sub ReplaceNewlinesEmailBody(AWith)
FBody = Replace(FBody, NL_, AWith)
End Sub
Sub CloseEmail
If FEmailType = ET_HTML Then
FBody = FBody & NL_ & "</table>" & NL_
FBody = FBody & "</body>" & NL_ & "</html>"
End If
End Sub
' (SS,19/9/05) parses through comma separated field list, getting first non blank value
Function GetFormValue(AFieldList)
Dim i, c, LLength, LFieldName, LFieldValue
LLength = Len(AFieldList)
LFieldName = ""
LFieldValue = ""
For i = 1 To LLength
c = Mid(AFieldList, i, 1)
' if comma or last char, i.e. we have a field
If c <> "," Then LFieldName = LFieldName + c
If c = "," Or i = LLength Then
LFieldName = Trim(LFieldName)
If LFieldName <> "" Then
LFieldValue = Request.Form(LFieldName)
If LFieldValue <> "" Then
Exit For ' non blank field found so exit for loop
End If
LFieldName = ""
End If
End If
Next
GetFormValue = Trim(LFieldValue)
End Function
' (SS,19/9/05) very simple check for valid email address
' checks to make sure it has a '@' and a '.' and there are no spaces
Function IsValidEmailAddress(AEmailAddress)
If InStr(AEmailAddress, "@") = 0 Or InStr(AEmailAddress, ".") = 0 Or InStr(AEmailAddress, " ") <> 0 Then
IsValidEmailAddress = False
Else
IsValidEmailAddress = True
End If
End Function
' (SS,20/9/05) checks for spammer, if 2 of these fields are the same (but not blank)
' or if Name or Telephone contain the "@" character then it must be a spammer
Function IsSpammer(AName, ATelephone, AEmail)
If AName <> "" And AEmail <> "" And AName = AEmail Then
IsSpammer = True
ElseIf AName <> "" And ATelephone <> "" And AName = ATelephone Then
IsSpammer = True
ElseIf AEmail <> "" And ATelephone <> "" And AEmail = ATelephone Then
IsSpammer = True
ElseIf InStr(AName, "@") > 0 Or InStr(ATelephone, "@") > 0 Then
IsSpammer = True
ElseIf IsSpamEmailAddress(AEmail) Then
IsSpammer = True
Else
IsSpammer = False
End If
End Function
' (SS,19/12/06) checks for particular address, returns true if found
Function IsSpamEmailAddress(AEmail)
' (SS,5/4/22) added eric.jones.z.mail@gmail.com to following
' (SS,26/5/24) added sample@email.tst
Const BAD_EMAIL_ADDRESSES = "zzy@hotmail.com,eric.jones.z.mail@gmail.com,sample@email.tst" ' to be comma separated
Dim Result
If InStr("," + BAD_EMAIL_ADDRESSES + ",", "," + AEmail + ",") > 0 Then
Result = True
Else
Result = False
End If
IsSpamEmailAddress = Result
End Function
' (SS,29/9/04) writes given text to given file name '
' if file exists it is appended to else a new file created '
' there must be modify and write access for Internet Guest account to this file or folder '
Sub WriteToFile(AFileName, LText)
Const ForAppending = 8
Application.Lock
Dim LobjOpenFile, LobjFSO, LstrPath
LstrPath = Server.MapPath(AFileName)
Set LobjFSO = Server.CreateObject("Scripting.FileSystemObject")
If LobjFSO.FileExists(LstrPath) Then
Set LobjOpenFile = LobjFSO.OpenTextFile(LstrPath, ForAppending)
Else
Set LobjOpenFile = LobjFSO.CreateTextFile(LstrPath)
End If
LobjOpenFile.Write LText
LobjOpenFile.Close
Set LobjOpenFile = Nothing
Set LobjFSO = Nothing
Application.UnLock
End Sub
' (SS,19/9/05) removed AFrom
' (SS,15/3/06) modified to make use of FFromAddress
' (SS,11/6/19) replaced DUNDAS (and old CDO) with new CDO code to send email (taken shopping from apputils.asp)
Sub SendEmail(ASubject, ATo, ABcc1, ABcc2)
CloseEmail ' close the table tags etc because OpenEmail would have been called '
' (SS,19/9/05) do not send email if Name, Email and Telephone are the same
' added this to hopefully overcome the form spamming we've been recently getting
Dim LName, LEmail, LTelephone
LName = GetFormValue("Name, FullName, Full_name, Full Name")
LEmail = GetFormValue(EMAIL_NAMES)
LTelephone = GetFormValue(TELEPHONE_NAMES)
' (SS,19/9/05) if blank email and telephone not allowed then exit if they are blank
If Not FAllowBlankEmailAndTel Then
If LEmail = "" And LTelephone = "" Then
FErrorMessage = "No enquiry sent. Email address or telephone missing.<br><br>Please go back and correct."
DoResponseWrite(FErrorMessage)
Exit Sub
End If
End If
' (SS,19/9/05) set the from address to be the entered email address if it is valid
' also exists if email is given and is invalid
Dim LFrom
' (SS,15/3/06) added If FFromAddress so that it is used if specified
If FFromAddress <> "" Then
LFrom = FFromAddress
Else
If IsValidEmailAddress(LEmail) Then
LFrom = LEmail
Else
LFrom = ATo
If LEmail <> "" Then
FErrorMessage = "No enquiry sent. Email address is invalid.<br><br>Please go back and correct."
DoResponseWrite(FErrorMessage)
Exit Sub
End If
End If
End If
' (SS,19/9/05) spammer check, exit if spammer detected
If IsSpammer(LName, LTelephone, LEmail) Then
' FErrorMessage = "Thank you. But you're a spammer! Please show some dignity!"
' (SS,5/4/22) replaced above with following
FErrorMessage = "Thank you. (SP)"
' (SS,1/11/05) added If FSpamLogEnabled
If FSpamLogEnabled Then
WriteToFile "\common\asp\spamlog.txt", Now & Chr(9) & Request.ServerVariables("HTTP_HOST") + Request.ServerVariables("SCRIPT_NAME") + Chr(9) + LName + Chr(9) + LTelephone + Chr(9) + LEmail + Chr(13) + Chr(10)
End If
DoResponseWrite(FErrorMessage)
Exit Sub
End If
' (SS,18/12/06) added If IsDebugMode to not send email but display on screen
If IsDebugMode Then
DoResponseWrite("<br><font face=""courier"">============EMAIL============</font><br>" & NL_)
DoResponseWrite("To: " & ATo & "<br>" & NL_)
DoResponseWrite("Bcc: " & ABcc1 & IIf(ABcc2 = "", "", ", ") & ABcc2 & "<br>" & NL_)
DoResponseWrite("IBcc: " & FInternalBccAddress & "<br>" & NL_)
DoResponseWrite("From: " & LFrom & "<br>" & NL_)
DoResponseWrite("Subject: " & ASubject & "<br>" & NL_)
DoResponseWrite("<br>" & NL_)
If FEmailType = ET_HTML Then
DoResponseWrite(FBody)
Else
DoResponseWrite("<font face=""Courier New"">")
DoResponseWrite(Replace(Replace(FBody, " ", " "), NL_, "<br>"))
DoResponseWrite("</font>")
End If
DoResponseWrite("<br><font face=""courier"">=============================</font><br>" & NL_)
' (SS,11/6/19) replaced old DUNDAS code and old CDO code with call to SendEmailByCDO_ (copied from apputils.asp from shopping)
Else
SendEmailByCDO_ ATo, ABcc1, ABcc2, LFrom, ASubject, FBody, "", FEmailType = ET_HTML, "", ""
End If
FErrorMessage = ""
DoResponseWrite(FThankYouText)
ClearSecurityCode ' (SS,28/5/08) prevents extra emails from being sent when user press refresh when Security Code is used
End Sub
' (SS,10/6/07) *** followings settings to be held in a common database
' (SS,11/6/19) copied following here from apputils.asp from shopping sites
' called by Function SendEmailByCDO_ below
' added underscore to keep unique
Function GetMailServer_(AServerNo)
If AServerNo = 1 Then
GetMailServer_ = "mail.itpartnership.com"
ElseIf AServerNo = 2 Then
GetMailServer_ = "mail.ontheworldweb.com"
Else
GetMailServer_ = ""
End If
End Function
' (SS,10/6/06) send email using CDO, returns False if there was a failure
' (SS,28/9/12) added AEmbeddedImage to allow image to be embedded inside the email
' (SS,11/6/19) this now replaces DUNDAS (no longer used and not added to new server)
' renamed from SendEmailByCDO to SendEmail_ (NB. Underscore at the end to ensure unique name)
' because SendEmailByCDO also exists in apputils.asp for shopping sites
' Modified call to GetMailServer to GetMailServer_ (above)
' Modified to handle FInternalBccAddress as an extra BCC (as used by old DUNDAS code)
Function SendEmailByCDO_(ATo, ABcc, ABcc2, AFrom, ASubject, ABody, AFiles, AIsHTML, AUrl, AEmbeddedImage)
' Create CDO message object
Dim objMessage
Set objMessage = CreateObject("CDO.Message")
' Set configuration fields.
With objMessage.Configuration.Fields
Const SCHEMA_PREFIX = "http://schemas.microsoft.com/cdo/configuration/"
' Original sender email address
.Item(SCHEMA_PREFIX & "sendemailaddress") = AFrom
' SMTP settings - without authentication, using standard port 25 on host smtp
.Item(SCHEMA_PREFIX & "sendusing") = 2 ' cdoSendUsingPort
.Item(SCHEMA_PREFIX & "smtpserverport") = 25
.Item(SCHEMA_PREFIX & "smtpserver") = GetMailServer_(1)
' SMTP Authentication
.Item(SCHEMA_PREFIX & "smtpauthenticate") = 0 ' cdoAnonymous
' Timeout
.Item(SCHEMA_PREFIX & "smtpconnectiontimeout") = 10
.Update
End With
' Set other message fields.
With objMessage
' From, To, Subject And Body are required.
.From = AFrom
.To = ATo
.Subject = ASubject
' if AUrl is provided then build the email from given web page
If AUrl <> "" Then
.CreateMHTMLBody AUrl
ElseIf AIsHTML Then
' if HTML then set the HTML body
.HTMLBody = ABody
' (SS,28/9/12) embed image if supplied, image must be in the images folder
If AEmbeddedImage <> "" Then
' (SS,28/9/12) embed the image, the HTML must contain something like <img src="cid:myimage.gif">
' with help from http://support.jodohost.com/threads/tut-how-to-add-embedded-images-in-cdo-mail.7692/
Dim objBP
' Const CdoReferenceTypeName = 1
Set objBP = objMessage.AddRelatedBodyPart(Server.MapPath("/images/" & AEmbeddedImage), AEmbeddedImage, 1)
objBP.Fields.Item("urn:schemas:mailheader:Content-ID") = "<" & AEmbeddedImage & ">"
objBP.Fields.Update
End If
Else
' else normal plain text
.TextBody = ABody
End If
' Blind copy and attachments are optional.
If ABcc <> "" Then .BCC = ABcc
If ABcc2 <> "" Then .BCC = .BCC + ";" + ABcc2
' (SS,11/6/19) added following to also handle extra internal BCC (as used by old DUNDAS code)
If FInternalBccAddress <> "" Then
.BCC = .BCC + ";" + FInternalBccAddress ' (SS,19/9/05) internal test blind copy
End If
If AFiles <> "" Then .AddAttachment AFiles
' Send the email and check for failure
On Error Resume Next
.Send
' if failed then try other mail servers
Dim LMailServer, LMailServerNo
LMailServerNo = 2
Do While Err.Number <> 0
LMailServer = GetMailServer_(LMailServerNo)
If LMailServer = "" Then Exit Do
LMailServerNo = LMailServerNo + 1
With objMessage.Configuration.Fields
.Item(SCHEMA_PREFIX & "smtpserver") = LMailServer
.Update
End With
On Error Resume Next ' cancels the previous error message, i.e. Err.Number starts again at zero
.Send
Loop
End With
' Returns zero If succesfull. Error code otherwise
SendEmailByCDO_ = Err.Number = 0
' clean up
Set objMessage = Nothing
End Function
' (SS,30/10/08) all Response.Writes call this, allows use to just return the text instead
Sub DoResponseWrite(AText)
FResponseWriteText = FResponseWriteText & AText
If FResponseWrite Then
Response.Write(AText)
End If
End Sub
' (SS,19/9/05) returns true if form field exists
Function FormFieldExists(AFieldName)
Dim LName
FormFieldExists = False
For Each LName in Request.Form
If UCase(LName) = UCase(AFieldName) Then
FormFieldExists = True
Exit For
End If
Next
End Function
' (SS,19/9/05) new easier version to use
Function SendEmailEasy(ASubject, ATo, ABcc1, ABcc2, APriorityFields, ASendAllFields)
' set up certain priority fields
Dim LPriorityFields
If ASendAllFields Then
LPriorityFields = "Title,Name,Company,Organisation,Address,Address1,Address2,AddressLine1,AddressLine2,Town,City,County,Postcode,Country,Telephone,Tel,Fax,Email,EmailAddress"
Else
LPriorityFields = ""
End If
LPriorityFields = LPriorityFields + "," + APriorityFields
OpenEmail FEmailType, FPlainTextHeadingSpaces
If FEmailType = ET_HTML Then
AddToEmail "", "<b>" + ASubject + ":</b><br><br>"
End If
' parse the priority field list adding the fields
Dim i, c, LLength, LFieldName, LFieldList
LFieldList = LPriorityFields
LLength = Len(LFieldList)
LFieldName = ""
For i = 1 To LLength
c = Mid(LFieldList, i, 1)
' if comma or last char, i.e. we have a field
If c <> "," Then LFieldName = LFieldName + c
If c = "," Or i = LLength Then
LFieldName = Trim(LFieldName)
If LFieldName <> "" Then
If FormFieldExists(LFieldName) Then
AddToEmail LFieldName, Trim(Request.Form(LFieldName))
End If
LFieldName = ""
End If
End If
Next
' if send all fields chosen then add all remaining form fields not already in priority list
If ASendAllFields Then
Dim LName
Const IGNORE_FIELDS = ",SUBMIT," ' submit field to be ignored
LFieldList = UCase("," + LPriorityFields + ",")
For Each LName in Request.Form
If InStr(LFieldList, "," + UCase(LName) + ",") = 0 And InStr(LFieldList, ", " + UCase(LName) + ",") = 0 Then
If InStr(IGNORE_FIELDS, "," + UCase(LName) + ",") = 0 Then
AddToEmail LName, Request.Form(LName)
End If
End If
Next
End If
SendEmail ASubject, ATo, ABcc1, ABcc2
End Function
' (SS,15/3/06) read given file to FBody string
Function GetBodyFromFile(AFileName)
FBody = ""
Dim LobjOpenFile, LobjFSO, LstrPath
LstrPath = Server.MapPath(AFileName)
Set LobjFSO = Server.CreateObject("Scripting.FileSystemObject")
If LobjFSO.FileExists(LstrPath) Then
Set LobjOpenFile = LobjFSO.OpenTextFile(LstrPath)
FBody = LobjOpenFile.ReadAll
LobjOpenFile.Close
Set LobjOpenFile = Nothing
End If
Set LobjFSO = Nothing
End Function
' (SS,15/3/06) replace given token in FBody with AValue
Sub SetBodyToken(AToken, AValue)
FBody = ReplaceStr(FBody, AToken, AValue)
End Sub
' (SS,15/3/06) from dbfunctions.asp Replace in String AStr, all occurrences of AReplace with AWith '
Function ReplaceStr(AStr, AReplace, AWith)
Dim p, LStr
ReplaceStr = ""
LStr = AStr
Do While LStr <> ""
p = InStr(LStr, AReplace)
If p > 0 Then
ReplaceStr = ReplaceStr + Mid(LStr, 1, p - 1) + AWith
LStr = Mid(LStr, p + Len(AReplace), Len(LStr))
Else
ReplaceStr = ReplaceStr + LStr
LStr = ""
End if
Loop
End Function
' (SS,19/12/06) special version which sends short text emails
Sub SendSmsEmail(ASubject, ATo, AFields)
If Not GetIsValidForm Then Exit Sub ' only email if form is valid
OpenEmail "TEXT", 0
SetThankYou ""
Dim LItems, i, LValue, LDoComma
LItems = Split(AFields, ",")
LDoComma = False
For i = 0 To UBound(LItems)
LValue = Trim(Request.Form(Trim(LItems(i))))
If LValue <> "" Then
AddToEmail "", IIf(LDoComma, ", ", "") + LValue
LDoComma = True
End If
Next
ReplaceNewlinesEmailBody "" ' remove newlines from email body
SendEmail ASubject, ATo, "", ""
End Sub
'==== START OF FORM ROUTINES =======================
' (SS,12/12/06)
Dim FFormWidth, FFormBorderColor, FFormTitleClass, FFormErrorClass, FFormLeftClass, FFormRightClass, FFormMainClass, FFormTitleText, FFormDefaultSize, FFocusField, FGetIsValidForm
Const FI_LABEL = 1, FI_NAME = 2, FI_REQUIRED = 3, FI_INPUTTYPE = 4, FI_SIZE = 5, FI_ROWS = 6, FI_DESC1 = 7, FI_DESC2 = 8
Const IT_TEXT = "text", IT_TEXTAREA = "textarea", IT_CHECKBOX = "checkbox", IT_RADIOGROUP = "radio", IT_COMBOBOX = "combobox", IT_SECURITY = "security", IT_BLANK = "blank", IT_SUBMIT = "submit"
Const QFI_TEXTBOX = "", QFI_TEXTAREA = "T", QFI_CHECKBOX = "C", QFI_RADIOGROUP = "G", QFI_COMBOBOX = "S"
Dim FFormItems, FFormItemsCount
Redim FFormItems(8, 0)
Dim FDebugMode
Dim FFormDesc1, FFormDesc2, FFormSecurityEnabled
InitialiseForm
Sub InitialiseForm
FFormWidth = "100%"
FFormBorderColor = "#FFFFFF"
FFormTitleClass = "formttl"
FFormErrorClass = "formerr"
FFormLeftClass = "formlft"
FFormRightClass = "formrt"
FFormMainClass = "form" ' (SS,19/5/08)
FFormDefaultSize = "40"
FFocusField = ""
FGetIsValidForm = False
FFormTitleText = "Please fill in this form with your enquiry:"
FFormItemsCount = 0
' set default for security type (CodeLength, Distort, DistortEx, Noise)
' (SS,21/11/11) changed DistortEx from False to True and False to True for Noise, to reduce spam
' (SS,22/11/23) changed the code length from 4 to 8
' (SS,28/11/23) changed the code length from 8 to 6
SetSecurityType 6, True, True, True
' set default to address to info@thisdomain.com
Dim LDomain, LPos
LDomain = Request.ServerVariables("HTTP_HOST")
LPos = InStr(LDomain, ".")
If LPos > 0 Then LDomain = Mid(LDomain, LPos + 1, Len(LDomain))
SetToAddress "info@" & LDomain
SetDebugOff
FFormSecurityEnabled = True
FFormDesc1 = ""
FFormDesc2 = ""
End Sub
Sub SetDebugOn
FDebugMode = True
End Sub
Sub SetDebugOff
FDebugMode = False
End Sub
Function IsDebugMode
IsDebugMode = FDebugMode
End Function
Sub SetFormTitle(ATitle)
FFormTitleText = ATitle
End Sub
Sub OpenForm
FFormItemsCount = 0 ' ensures existing form entries are cleared
End Sub
' (SS,19/12/06)
' Width=100% i.e. Width
' BorderColor=#3074B8 i.e. Border Color
' LeftClass=formlft i.e. Left Class
' RightClass=formrt i.e. Right Class
Sub SetForm(AValues)
Const SF_WIDTH = "WIDTH"
Const SF_BORDER_COLOR = "BORDERCOLOR"
Const SF_TITLE_CLASS = "TITLECLASS"
Const SF_ERROR_CLASS = "ERRORCLASS"
Const SF_LEFT_CLASS = "LEFTCLASS"
Const SF_RIGHT_CLASS = "RIGHTCLASS"
Const SF_MAIN_CLASS = "MAINCLASS" ' (SS,19/5/08)
Dim AItems, i, LItem, LPos, LParam, LValue
AItems = Split(AValues, ",")
For i = 0 To UBound(AItems)
LItem = AItems(i)
LPos = InStr(LItem, "=")
If LPos > 0 Then
LParam = Trim(UCase(Left(LItem, LPos - 1)))
LValue = Trim(Mid(LItem, LPos + 1, Len(LParam)))
Else
LParam = ""
LValue = ""
End If
If LParam = SF_WIDTH Then
FFormWidth = LValue
ElseIf LParam = SF_BORDER_COLOR Then
FFormBorderColor = LValue
ElseIf LParam = SF_TITLE_CLASS Then
FFormTitleClass = LValue
ElseIf LParam = SF_ERROR_CLASS Then
FFormErrorClass = LValue
ElseIf LParam = SF_LEFT_CLASS Then
FFormLeftClass = LValue
ElseIf LParam = SF_RIGHT_CLASS Then
FFormRightClass = LValue
' (SS,19/5/08)
ElseIf LParam = SF_MAIN_CLASS Then
FFormMainClass = LValue
End If
Next
End Sub
' (SS,31/1/07)
Sub AddFormDesc(ADesc1, ADesc2)
FFormDesc1 = ADesc1
FFormDesc2 = ADesc2
End Sub
Sub AddFormItem(ALabel, AName, ARequired, AInputType, ASize, ARows)
If AInputType = "" Then AInputType = IT_TEXT
' add new element to array without losing current contents for array
FFormItemsCount = FFormItemsCount + 1
Redim Preserve FFormItems(8, FFormItemsCount)
FFormItems(FI_LABEL, FFormItemsCount) = ALabel
FFormItems(FI_NAME, FFormItemsCount) = AName
FFormItems(FI_REQUIRED, FFormItemsCount) = ARequired
FFormItems(FI_INPUTTYPE, FFormItemsCount) = AInputType
FFormItems(FI_SIZE, FFormItemsCount) = ASize
FFormItems(FI_ROWS, FFormItemsCount) = ARows
' (SS,31/1/07)
FFormItems(FI_DESC1, FFormItemsCount) = FFormDesc1
FFormItems(FI_DESC2, FFormItemsCount) = FFormDesc2
FFormDesc1 = "" ' clear the description ready for next AddFormItem
FFormDesc2 = ""
End Sub
Sub AddFormSecurity
If FFormSecurityEnabled Then
AddFormItem "Security Code", "SecurityCode", True, IT_SECURITY, "", ""
End If
End Sub
' adds a blank line
Sub AddFormBlank
AddFormItem "", "", False, IT_BLANK, "", ""
End Sub
Sub AddFormSubmit(ASubmit)
AddFormItem "", "", False, IT_SUBMIT, ASubmit, ""
End Sub
Function InputTypeExists(AInputType)
Dim i
InputTypeExists = False
For i = 1 To FFormItemsCount
If FFormItems(FI_INPUTTYPE, i) = AInputType Then
InputTypeExists = True
Exit For
End If
Next
End Function
Sub CloseForm
If Not InputTypeExists(IT_SECURITY) Then AddFormSecurity
If Not InputTypeExists(IT_SUBMIT) Then AddFormSubmit ""
If IsValidForm Then
SetUpAndSendEmail
Else
ShowForm
End If
End Sub
' Name:R,Telephone:R
' R for required
' L= for Label
' T for textarea
' C for checkbox
' S for Select/Combo (with W= semicolon separated values)
' G for radio group (with W= semicolon separated values)
' W= for width of textbox/text area
' ?H= for rows for textarea (i.e. Height)
' Q= for quick form, can be =ATC (where A is Address, T is Title, C is Company)
' NOTES
' use T for textarea, nothing for
' use B for basic
' (SS,4/7/07) added QF_QUICK_EMAIL_REQUIRED, for email to be required if "M" included
Sub QuickForm(AFieldList)
Const QF_REQUIRED = "R"
Const QF_LABEL = "L="
Const QF_WIDTH = "W="
Const QF_ROWS = "H="
Const QF_VALUES = "V="
Const DEFAULT_TEXTBOX_WIDTH = "38"
Const DEFAULT_TEXTAREA_WIDTH = "37"
Const DEFAULT_TEXTAREA_ROWS = "5"
Const QF_QUICK = "Q="
Const QF_QUICK_ADDRESS = "A"
Const QF_QUICK_TITLE = "T"
Const QF_QUICK_COMPANY = "C"
Const QF_QUICK_ENQUIRY = "E"
Const QF_QUICK_GAP = "G"
Const QF_QUICK_EXTRA = "X"
Const QF_QUICK_PHONE_REQUIRED = "P" ' to set telephone to be a required value
Const QF_QUICK_EMAIL_REQUIRED = "M" ' to set email to be a required value
If AFieldList = "" Then AFieldList = "Q=E" ' i.e. if nothing defined then use default Name, Telephone, Email and Enquiry
Dim LItems
LItems = Split(AFieldList, ",")
Dim LLabel, LName, LRequired, LInputType, LSize, LRows
Dim i, n, p, LValue, LParam, LParamItems, LSingleParam, LEqualsParam, LEqualsValue
OpenForm
For i = 0 To Ubound(LItems)
LValue = Trim(LItems(i))
If Mid(LValue, 1, Len(QF_QUICK)) = QF_QUICK Then
If Instr(LValue, QF_QUICK_TITLE) > 0 Then
AddFormItem "Title", "", False, "", "8", ""
End If
AddFormItem "Full Name", "Name", True, "", "38", ""
If Instr(LValue, QF_QUICK_COMPANY) > 0 Then
AddFormItem "Company", "", False, "", "", ""
End If
If Instr(LValue, QF_QUICK_ADDRESS) > 0 Then
If Instr(LValue, QF_QUICK_GAP) > 0 Then AddFormBlank
AddFormItem "Address Line 1", "", False, "", "", ""
AddFormItem "Address Line 2", "", False, "", "", ""
AddFormItem "City", "", False, "", "", ""
AddFormItem "County/State", "County", False, "", "", ""
AddFormItem "Country", "Country", False, "", "", ""
AddFormItem "Postcode", "", False, "", "", ""
End If
If Instr(LValue, QF_QUICK_GAP) > 0 Then AddFormBlank
AddFormItem "Telephone", "", Instr(LValue, QF_QUICK_PHONE_REQUIRED) > 0, "", "", ""
AddFormItem "Email", "", Instr(LValue, QF_QUICK_EMAIL_REQUIRED) > 0, "", "", ""
If Instr(LValue, QF_QUICK_ENQUIRY) > 0 Then
AddFormItem "Enquiry", "", False, IT_TEXTAREA, "37", "5"
End If
Else
p = InStr(LValue, ":")
If p = 0 Then
LName = Trim(LValue)
LParam = ""
Else
LName = Trim(Left(LValue, p - 1))
LParam = Mid(LValue, p + 1, Len(LValue))
End If
LParamItems = Split(LParam, ":")
LLabel = ""
LRequired = False
LInputType = QFI_TEXTBOX ' default to Textbox
LSize = ""
LRows = ""
For n = 0 To Ubound(LParamItems)
LSingleParam = Trim(LParamItems(n))
If LSingleParam = QF_REQUIRED Then
LRequired = True
ElseIf LSingleParam = QFI_TEXTAREA Or LSingleParam = QFI_CHECKBOX Or LSingleParam = QFI_COMBOBOX Or LSingleParam = QFI_RADIOGROUP Then
LInputType = LSingleParam
Else
LEqualsParam = Left(LSingleParam, 2)
LEqualsValue = Mid(LSingleParam, 3)
If LEqualsParam = QF_LABEL Then
LLabel = LEqualsValue
ElseIf LEqualsParam = QF_WIDTH Then
LSize = LEqualsValue
ElseIf LEqualsParam = QF_VALUES Then
LSize = LEqualsValue
ElseIf LEqualsParam = QF_ROWS Then
LRows = LEqualsValue
End If
End If
Next
If LInputType = QFI_TEXTBOX Then
If LSize = "" Then
LSize = DEFAULT_TEXTBOX_WIDTH
End If
ElseIf LInputType = QFI_TEXTAREA Then
If LSize = "" Then
LSize = DEFAULT_TEXTAREA_WIDTH
End If
If LRows = "" Then
LRows = DEFAULT_TEXTAREA_ROWS
End If
End If
LInputType = ConvertQFToInputType(LInputType)
AddFormItem LLabel, LName, LRequired, LInputType, LSize, LRows
End If
Next
If Instr(LValue, QF_QUICK_Extra) = 0 Then CloseForm ' close form if no extras defined
End Sub
Function ConvertQFToInputType(AQFValue)
Dim Result
If AQFValue = QFI_TEXTAREA Then
Result = IT_TEXTAREA
ElseIf AQFValue = QFI_CHECKBOX Then
Result = IT_CHECKBOX
ElseIf AQFValue = QFI_COMBOBOX Then
Result = IT_COMBOBOX
ElseIf AQFValue = QFI_RADIOGROUP Then
Result = IT_RADIOGROUP
Else
Result = IT_TEXT
End If
ConvertQFToInputType = Result
End Function
Sub ShowForm
Dim LCurrentPage, LPos, i, LInputType, LLabel, LInputName, LInputValue, LRequired, LSize, LRows, LDesc1, LDesc2
' (SS,16/1/07) get current page name, ignoring the leading '/' also added ?page=postform for webstats to see posted page
LCurrentPage = Request.ServerVariables("SCRIPT_NAME")
If Left(LCurrentPage, 1) = "/" Then LCurrentPage = Mid(LCurrentPage, 2, Len(LCurrentPage))
' (SS,12/7/07) added following to ignore subdirectory, because it wasn't working in a subdirectory of a site
LPos = InStrRev(LCurrentPage, "/")
If LPos > 0 Then LCurrentPage = Mid(LCurrentPage, LPos + 1, Len(LCurrentPage))
DoResponseWrite("<form action=""" + LCurrentPage + "?page=postform"" name=""ContactForm"" method=""post"" class=""nospace"">" & NL_)
DoResponseWrite("<table cellpadding=""0"" cellspacing=""2"">" & NL_)
If FFormTitleText <> "" Then
DoResponseWrite("<tr><td colspan=""2"" class=""" & FFormTitleClass & """>" & FFormTitleText & "</td></tr>")
End If
If FErrorMessage <> "" Then
DoResponseWrite("<tr><td colspan=""2"" class=""" & FFormErrorClass & """><b><font color=""red"">" & Replace(FErrorMessage, NL_, "<br>") & "</font></b></td></tr>")
End If
For i = 1 To FFormItemsCount
LInputType = LCase(Trim(FFormItems(FI_INPUTTYPE, i)))
LLabel = FFormItems(FI_LABEL, i)
LInputName = FFormItems(FI_NAME, i)
If LInputName = "" Then LInputName = FFormItems(FI_LABEL, i) ' if blank then use label as the name
If LLabel = "" Then LLabel = FFormItems(FI_NAME, i) ' if blank label then use name
LInputValue = Trim(Request.Form(LInputName))
LRequired = FFormItems(FI_REQUIRED, i)
LSize = FFormItems(FI_SIZE, i)
LRows = FFormItems(FI_ROWS, i)
LDesc1 = FFormItems(FI_DESC1, i)
LDesc2 = FFormItems(FI_DESC2, i)
If LInputName <> "" And FFocusField = "" Then FFocusField = LInputName ' to set focus to first field
If LInputType = IT_SECURITY Then
AddSecurityHeading ' (SS,28/5/08) moved code to new routine because it's called elsewhere
End If
DoResponseWrite("<tr>" & NL_)
DoResponseWrite("<td class=""" & FFormLeftClass & """")
' if text area then align label to top
If LInputType = IT_TEXTAREA Then DoResponseWrite(" valign=""top""")
DoResponseWrite(">")
If LLabel = "" Then
DoResponseWrite(" ")
Else
If LRequired Then
DoResponseWrite("<b>" & LLabel & "</b>")
Else
DoResponseWrite(LLabel)
End If
DoResponseWrite(":")
End If
DoResponseWrite("</td>" & NL_)
DoResponseWrite("<td class=""" & FFormRightClass & """>")
DoResponseWrite(LDesc1) ' (SS,31/1/07)
If LInputType = IT_TEXT Then
If LSize = "" Then
LSize = FFormDefaultSize
Else
FFormDefaultSize = LSize
End If
DoResponseWrite("<input type=""text"" name=""" & LInputName & """ size=""" & LSize & """ class=""" & FFormMainClass & """ value=""" & LInputValue & """>")
ElseIf LInputType = IT_TEXTAREA Then
DoResponseWrite("<textarea name=""" & LInputName & """ cols=""" & LSize & """ rows=""" & LRows & """ class=""" & FFormMainClass & """ value=""" & LInputValue & """>" & LInputValue & "</textarea>")
ElseIf LInputType = IT_CHECKBOX Then
DoResponseWrite("<input type=""checkbox"" name=""" & LInputName & """ value=""Yes""" & IIf(LInputValue="Yes", " checked", "") & ">")
ElseIf LInputType = IT_RADIOGROUP Then
DoResponseWrite(GetRadioGroup(LInputName, LSize, LInputValue))
ElseIf LInputType = IT_COMBOBOX Then
DoResponseWrite(GetSelect(LInputName, LSize, LInputValue))
ElseIf LInputType = IT_SECURITY Then
AddSecurityTextBox False ' (SS,28/5/08) moved code to new AddSecurityTextBox, called from elsewhere too, False means don't add table cell
ElseIf LInputType = IT_SUBMIT Then
If LSize = "" Then
DoResponseWrite("<input type=""submit"" name=""submit"" class=""" & FFormMainClass & """ value=""Submit"">")
Else
DoResponseWrite("<input type=""image"" name=""submit"" class=""" & FFormMainClass & """ src=""" & LSize & """ style=""CURSOR: hand"">")
End If
Else ' i.e. IT_BLANK
DoResponseWrite(" ")
End If
DoResponseWrite(LDesc2) ' (SS,31/1/07)
DoResponseWrite("</td>" & NL_)
DoResponseWrite("</tr>" & NL_)
Next
DoResponseWrite("<tr><td> </td><td class=""" & FFormRightClass & """>Fields in <b>Bold</b> must be filled in.</td></tr>" & NL_)
DoResponseWrite("<input type=""hidden"" name=""postform"" class=""" & FFormMainClass & """ value=""yes"">" & NL_)
DoResponseWrite("</table>" & NL_)
DoResponseWrite("</form>" & NL_)
%>
<script language="JavaScript" type="text/JavaScript">
<!--
function Init()
{
if (itpErrorMessage != '') {alert(itpErrorMessage)};
if (itpFocusField != '') {document.getElementsByName(itpFocusField)[0].focus()};
}
itpErrorMessage = '<%=Replace(FErrorMessage, NL_, "\n")%>';
itpFocusField = '<%=FFocusField%>';
window.onload = Init;
//-->
</script>
<%
End Sub
Function GetSelect(AInputName, AValues, ADefault)
Dim Result, LItems, i, LValue
Result = "<select name=""" & AInputName & """ class=""" & FFormMainClass & """>" & NL_
LItems = Split(AValues, ";")
For i = 0 To UBound(LItems)
LValue = Trim(LItems(i))
If LValue = ADefault Then
Result = Result + "<option selected>"
Else
Result = Result + "<option>"
End If
Result = Result + LValue + "</option>" & NL_
Next
Result = Result + "</select>" & NL_
GetSelect = Result
End Function
Function GetRadioGroup(AInputName, AValues, ADefault)
Dim Result, LItems, i, LValue
LItems = Split(AValues, ";")
For i = 0 To UBound(LItems)
LValue = Trim(LItems(i))
Result = Result + LValue + "<input type=""radio"" name=""" & AInputName & """ class=""" & FFormMainClass & """ value=""" & LValue & """" + IIf(LValue = ADefault, " checked", "") + ">" & NL_
Next
GetRadioGroup = Result
End Function
Sub SetUpAndSendEmail
OpenEmail "", 0
If FSetEmailTitle <> "" Then AddToEmail "", FSetEmailTitle ' (SS,5/2/07)
Dim i, LInputType, LLabel, LInputName, LInputValue
For i = 1 To FFormItemsCount
LInputType = LCase(Trim(FFormItems(FI_INPUTTYPE, i)))
If LInputType = IT_TEXT Or LInputType = IT_TEXTAREA Then
LLabel = FFormItems(FI_LABEL, i)
LInputName = FFormItems(FI_NAME, i)
If LInputName = "" Then LInputName = FFormItems(FI_LABEL, i) ' if blank then use label as the name
If LLabel = "" Then LLabel = LInputName
LInputValue = Trim(Request.Form(LInputName))
AddToEmail LLabel, LInputValue
End If
Next
SendEmail FSubject, FToAddress, FBccAddress, FBcc2Address
Session("SecurityCode") = "" ' clear the security code in case user refresh to send form again
End Sub
' returns true if second parameter is in the comma separated first string
Function InList(AList, AToCheck)
InList = InStr("," + UCase(AList) + ",", "," + UCase(AToCheck) + ",") > 0
End Function
Function SetFocusField(AField)
If FFocusField = "" Then FFocusField = AField
End Function
Function IsValidForm
ClearErrorMessage
FFocusField = ""
IsValidForm = False
FGetIsValidForm = False
If Request.Form("postform") <> "yes" Then
Exit Function
End If
If FDebugMode Then
DoResponseWrite("<br>===========FORM VALUES===========<br>" & NL_)
End if
Dim i, LRequired, LInputName, LInputLabel, LInputType, LInputValue
Dim LBlankTelephone, LBlankEmail, LRequiredTelephone, LRequiredEmail, LEmailField
LBlankTelephone = False
LBlankEmail = False
LRequiredTelephone = False
LRequiredEmail = False
LEmailField = ""
For i = 1 To FFormItemsCount
LInputName = FFormItems(FI_NAME, i)
LInputLabel = FFormItems(FI_LABEL, i)
LInputType = FFormItems(FI_INPUTTYPE, i)
LInputValue = ""
If LInputName = "" Then LInputName = LInputLabel ' if blank then use label as the name
If LInputLabel = "" Then LInputLabel = LInputName ' if blank then use name as the label
If LInputName <> "" Then
LInputValue = Trim(Request.Form(LInputName))
LRequired = FFormItems(FI_REQUIRED, i)
If FFormItems(FI_REQUIRED, i) And LInputValue = "" Then
AddErrorMessage(LInputLabel + " must be entered")
SetFocusField LInputName
End If
' Session("SecurityCode") would be set by getsecurityimg.asp
If LInputType = IT_SECURITY And LInputValue <> Session("SecurityCode") And LInputValue <> "" Then
AddErrorMessage(LInputLabel + " is incorrect")
SetFocusField LInputName
End If
' make sure email address is valid
If InList(EMAIL_NAMES, LInputName) Then
LRequiredTelephone = LRequired
If LInputValue <> "" Then
If Not IsValidEmailAddress(LInputValue) Then
AddErrorMessage("Email address is incorrect")
SetFocusField LInputName
End If
Else
LBlankEmail = True
LEmailField = LInputName
End If
ElseIf InList(TELEPHONE_NAMES, LInputName) Then
LRequiredEmail = LRequired
If LInputValue = "" Then
LBlankTelephone = True
End If
End If
End If
If FDebugMode Then
DoResponseWrite(LInputName & ", " & LInputLabel & ", " & LInputType & ", " & LInputValue & ", " & FFormItems(FI_SIZE, i) & ", " & FFormItems(FI_ROWS, i) & "<br>" & NL_)
End If
Next
If FDebugMode Then
DoResponseWrite("===============================<br>" & NL_)
End if
If Not LRequiredTelephone And Not LRequiredEmail And LBlankTelephone And LBlankEmail Then
AddErrorMessage("Either Telephone or Email must be entered")
SetFocusField LEmailField
End If
FGetIsValidForm = FErrorMessage = ""
IsValidForm = FGetIsValidForm
End Function
' (SS,13/12/06) returns the result of IsValidForm, used by calling code
Function GetIsValidForm
GetIsValidForm = FGetIsValidForm
End Function
Sub ClearErrorMessage
FErrorMessage = ""
End Sub
Sub AddErrorMessage(AMessage)
If FErrorMessage <> "" Then FErrorMessage = FErrorMessage & NL_
FErrorMessage = FErrorMessage + AMessage
End Sub
' Immediate If function
Function IIf(a, b, c)
If a Then IIf = b Else IIf = c
End Function
' (SS,12/12/06) returns true if security code created by aspcaptha.asp is valid
Function CheckSecurityCode
If Trim(Session("CAPTCHA")) = "" Then ' i.e. value couldn't be held in session
CheckSecurityCode = False
Else
CheckSecurityCode = Trim(Request.Form("SecurityCode")) = Trim(Session("CAPTCHA"))
End If
End Function
' (SS,12/12/06) sets codelength, distort, distortex and noise options for aspcaptha.asp
Sub SetSecurityType(ACodeLength, ADistort, ADistortEx, ANoise)
Session("CodeLength") = ACodeLength
Session("Distort") = ADistort
Session("DistortEx") = ADistortEx
Session("Noise") = ANoise
End Sub
' (SS,31/1/07)
Sub SetSecurityOff
FFormSecurityEnabled = False
End Sub
' (SS,20/5/09) added to allow left and right cell attributes to be set for more flexibility
Sub SetSecurityTDAttributes(AHeading, ALeft, ARight)
FSecurityTDHeadingAttributes = AHeading
FSecurityTDLeftAttributes = ALeft
FSecurityTDRightAttributes = ARight
End Sub
' (SS,20/5/09)
Function GetSecurityTDAttributes(AAttributes, AClass)
If AAttributes = "" Then
GetSecurityTDAttributes = " class=""" & AClass & """"
Else
GetSecurityTDAttributes = " " & AAttributes
End If
End Function
' (SS,28/5/08)
' (SS,11/5/10) modified to use FSecurityHeading
Sub AddSecurityHeading
DoResponseWrite("<tr><td> </td><td" & GetSecurityTDAttributes(FSecurityTDHeadingAttributes, FFormRightClass) & ">" & FSecurityHeading & "</td></tr>" & NL_)
End Sub
' (SS,28/5/08)
' (SS,11/5/10) modified to use FSecurityLabel
Sub AddSecurityLabel
DoResponseWrite("<tr>" & NL_)
DoResponseWrite("<td" & GetSecurityTDAttributes(FSecurityTDLeftAttributes, FFormLeftClass )& "><b>" & FSecurityLabel & "</b>:</td>")
End Sub
' (SS,28/5/08)
' (SS,1/3/15) added alt=""security image"" to remove error from W3C validator
Sub AddSecurityTextBox(AAddCell)
If AAddCell Then
DoResponseWrite("<td" & GetSecurityTDAttributes(FSecurityTDRightAttributes, FFormRightClass) & ">")
End If
' (SS,20/5/09) added align="absbottom"
DoResponseWrite("<input type=""text"" name=""SecurityCode"" autocomplete=""off"" size=""20"" class=""" & FFormMainClass & """ maxlength=""8""> <img src=""/common/asp/getsecurityimg.asp"" width=""86"" height=""21"" align=""absbottom"" alt=""security image"">")
If AAddCell Then
DoResponseWrite("</td>" & NL_)
DoResponseWrite("</tr>" & NL_)
End If
End Sub
' (SS,28/5/08)
Sub AddSecurityToExistingForm
AddSecurityHeading
AddSecurityLabel
AddSecurityTextBox True
End Sub
' (SS,4/9/14) special version for RWD frameworks i.e. bootstrap
' in future may need to replace "Enter number shown in red above" with FSecurityLabel which has more appropriate correct language version
' (SS,1/3/15) added alt=""security image"" to remove error from W3C validator
Sub AddSecurityControl(AType, AOptions)
If AType = "bootstrap" Then
DoResponseWrite "<label for=""SecurityCode"">" & FSecurityLabel & "</label>" & " <img src=""/common/asp/getsecurityimg.asp"" alt=""security image"">" & NL
DoResponseWrite "<input type=""text"" class=""form-control"" name=""SecurityCode"" autocomplete=""off"" id=""SecurityCode"" placeholder=""Enter number shown in red above"">" & NL
End If
End Sub
' (SS,28/5/08)
' (SS,4/12/08) added AAddMessage parameter
Function SecurityOK(AAddMessage)
SecurityOK = False
Dim LSecurityCode
LSecurityCode = Request.Form("SecurityCode")
If LSecurityCode = "" Then
If AAddMessage Then
DoResponseWrite("<font color=""red"">Please go back and enter the Security Code.</font>")
End If
ElseIf LSecurityCode <> Session("SecurityCode") Then
If AAddMessage Then
DoResponseWrite("<font color=""red"">The Security Code is incorrect.<br><br>Please go back and enter the correct the Security Code.</font>")
End If
Else
SecurityOK = True
End If
End Function
' (SS,28/5/08)
Sub ClearSecurityCode
Session("SecurityCode") = ""
End Sub
'==== END OF FORM ROUTINES =========================
%>