File: D:/web/common/asp/inc-emailtest.asp
<%
' (SS,15/03/06) Added SetFormAddress, GetBodyFromFile, SetBodyToken, ReplaceStr, changes SendEmail to use FFromAddress
' NOT TO BE TOUCHED BY SOCK (JEETS)'
Option Explicit
Dim NL
NL = Chr(13) + Chr(10)
Dim FEmailType, FPlainTextHeadingSpaces, FBody, FTableStyle, FAllowBlankEmailAndTel, FErrorMessage, FEmailer, FSpamLogEnabled
Dim FFromAddress
FEmailType = "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)
FFromAddress = "" ' (SS,15/3/06)
FBody = "" ' (SS,15/3/06)
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 = AType
FPlainTextHeadingSpaces = APlainTextHeadingSpaces
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
Function GetErrorMessage
GetErrorMessage = FErrorMessage
End Function
Sub OpenEmail(AType, APlainTextHeadingSpaces)
FBody = ""
FEmailType = AType
FPlainTextHeadingSpaces = APlainTextHeadingSpaces
If FEmailType = "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 = "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
Sub CloseEmail
If FEmailType = "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
Else
IsSpammer = False
End If
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
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 = FFromAddress 'GetFormValue("Email, EmailAddress, Email_address, Email Address")
LTelephone = GetFormValue("Telephone, Tel, TelNo, Tel No, Tel_no, Phone, PhoneNo, Phone No, Phone_no, PhoneNumber, Phone Number, Phone_number")
' (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."
Response.Write(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."
Response.Write(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,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
Response.Write(FErrorMessage)
Exit Sub
End If
If FEmailer = "DUNDAS" Then
' send the email using Dundas Mailer Control '
Dim objEmail ' Mailer control '
Set objEmail = Server.CreateObject("Dundas.Mailer")
// objEmail.SMTPRelayServers.Add "mail.itpartnership.com"
objEmail.SMTPRelayServers.Add "mail.ontheworldweb.com" ' (SS,19/9/05) added secondardy mail server
' set Mailer control properties and collection items '
objEmail.TOs.Add ATo
If ABcc1 <> "" Then objEmail.BCCs.Add ABcc1
If ABcc2 <> "" Then objEmail.BCCs.Add ABcc2
// objEmail.BCCs.Add "contactforms@itpartnership.com" ' (SS,19/9/05) internal test blind copy
objEmail.FromAddress = LFrom
objEmail.Subject = ASubject
If FEmailType = "HTML" Then
objEmail.HTMLBody = FBody
Else
objEmail.Body = FBody
End If
objEmail.SendMail
' you can test for the success/failure of the operation by examining VBScripts Err object here '
Set objEmail = Nothing
Else
' (SS,1/11/05) added following new CDO type for servers that don't have DUNDAS installed
' has a limitation compared to DUNDAS, i.e. you can't specify a mail server
Dim objSendMail
Set objSendMail = CreateObject("CDO.Message")
With objSendMail
.To = ATo
If ABcc1 <> "" Then .BCC = ABcc1
If ABcc2 <> "" Then .BCC = .BCC + ";" + ABcc2
.Sender = LFrom
.Subject = ASubject
If FEmailType = "HTML" Then
.HTMLBody = FBody
Else
.TextBody = FBody
End If
.Send
End With
Set objSendMail = Nothing
End If
FErrorMessage = ""
Response.Write("Thank you for your enquiry.<br><br>We will contact you very soon.")
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 = "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
%>