<% 'http://www.paulsadowski.com/WSH/psmail.htm ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ' COPYRIGHT, WAIVER OF LIABILITY, TERMS OF USE AND REDISTRIBUTION ' 'THE SOFTWARE IS PROVIDED BY THE AUTHOR "AS IS," AND "WITH ALL FAULTS". 'YOU UNDERSTAND AND EXPRESSLY AGREE THAT USE OF THE SOFTWARE/CODE ARE AT YOUR 'SOLE RISK, THAT ANY MATERIAL AND/OR DATA DOWNLOADED OR OTHERWISE OBTAINED 'IS AT YOUR OWN DISCRETION AND RISK AND THAT YOU WILL BE SOLELY RESPONSIBLE 'FOR ANY DAMAGE TO YOUR COMPUTER SYSTEM OR LOSS OF DATA THAT RESULTS FROM 'THE USE OF SUCH MATERIAL AND/OR DATA. ' 'IN NO EVENT WILL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 'SPECIAL, CONSEQUENTIAL OR PUNITIVE DAMAGES OF ANY KIND RESULTING HOWEVER 'THEY MAY ARISE AND EVEN IF THE AUTHOR HAS BEEN PREVIOUSLY ADVISED OF THE 'POSSIBILITY OF SUCH DAMAGES. ' 'YOU MAY NOT COPY, MODIFY, REPUBLISH, REPRODUCE, TRANSMIT, OR DISTRIBUTE 'IN WHOLE OR IN PART THIS APPLICATION/CODE. THIS COPYRIGHT DOES NOT 'SUPERSEDE ANY COPYRIGHTS THAT MAY EXIST IN THIRD-PARTY MATERIALS. ' 'YOU MAY NOT SELL, BARTER OR TRADE THIS SOFTWARE/CODE ITSELF OR AS PART OF 'ANOTHER APPLICATION, PACKAGE OR COLLECTION. ' 'THE AUTHOR MAY OR MAY NOT PROVIDE SUPPORT FOR THIS APPLICATION/CODE AT HIS 'SOLE DISCRETION. AT NO TIME WILL FREE SUPPORT BE PROVIDED TO OR ON BEHALF OF 'ISPS, DEVELOPERS, DESIGNERS, THIRD-PARTIES OR ANY OTHER COMMERCIAL ENTITIES. ' 'THIS NOTICE AND COPYRIGHT MAY NOT BE REMOVED FROM ANY COPY OR COPIES OF 'THIS APPLICATION/CODE. ' ' COPYRIGHT (C)(P) 2004 BY Paul R. Sadowski . ' ALL RIGHTS RESERVED. ' -- CONFIGURATION SECTION -- ' ' THIS IS THE DEFAULT RETURN FROM ADDRESS USED ONLY WHEN THE ' FORM DOES NOT SPECIFY ANOTHER FROM ADDRESS IN THE FORM'S 'FROM' FIELD. FromAddress = "" ' ALLOWEDHOSTS IS A COMMA SEPARATED LIST OF DOMAIN NAMES THAT ARE ALLOWED ' TO USE THIS FORM PROCESSOR. FOR EXAMPLE: ' www.mydomain.com, mydomain.com, www.mydomain.net, mydomain.net AllowedHosts = "" ' ALLOWEDREFERRERS IS A COMMA SEPARATED LIST OF URLS WHO ARE ' ALLOWED TO USE THIS FORM. THIS SHOULD BE THE COMPLETE URL LIKE ' http://myhost.com/support/feedback.htm, http://www.myhost.com/support/feedback.htm ' IT SHOULD INCLUDE ALL DOMAIN NAMES YOUR PAGE CAN BE ADDRESSED BY. AllowedReferrers = "" ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ' MAKE NO CHANGES BELOW THIS LINE Allow = False AllowedHosts = Replace(AllowedHosts, " ", "") AllowedReferrers = Replace(AllowedReferrers, " ", "") AllowedHosts = Replace(AllowedHosts, Chr(9), "") AllowedReferrers = Replace(AllowedReferrers, Chr(9), "") Hosts = Split(AllowedHosts, ",") Referrers = Split(AllowedReferrers, ",") strTo = Trim(CStr(Request.Form("psmto"))) strFrom = Trim(CStr(Request.Form("psmfrom"))) strSubject = Trim(CStr(Request.Form("psmsubject"))) strRedirect = Trim(CStr(Request.Form("psmredirect"))) if strSubject = "" then strSubject = "Website feedback from " & Request.ServerVariables ("HTTP_REFERER") end if if strFrom = "" then strFrom = FromAddress end if strTo = Replace(strTo, ";", ",") Rcpt = Split(strTo, ",") RebuildToString(Rcpt) Allow = Allowed(Hosts, BaseHost(Request.ServerVariables ("HTTP_REFERER"))) if Allow <> True then Allow = Allowed(Referrers, Request.ServerVariables ("HTTP_REFERER")) end if if strTo = "" or strFrom = "" then Response.Write("
Invalid or missing to or from field(s)
") elseif AllowedHosts = "" and AllowedReferrers = "" then Response.Write("
Configuration error: AllowedHosts or AllowedReferrers must not be empty
") elseif Allow = False then Response.Write("
You are not authorized to use this script. [referrers]
" & Request.ServerVariables ("HTTP_REFERER")) elseif strFrom <> "" and IsEmail(strFrom) = false then Response.Write("
Invalid sender.
") else strBody = strBody & "to: " & strTo & vbCRLF strBody = strBody & "from: " & strFrom & vbCRLF strBody = strBody & "subject: " & strSubject & vbCRLF & vbCRLF for each name in Request.Form if LCase(name) <> "psmto" and LCase(name) <> "psmfrom" and LCase(name) <> "psmsubject" and LCase(name) <> "psmredirect" then strBody = strBody & name & ": " & CStr(Request.Form(name)) & vbCRLF & vbCRLF end if next strBody = strBody & vbCRLF & vbCRLF strBody = strBody & "date: " & Now & vbCRLF strBody = strBody & "remote host: " & Request.ServerVariables ("REMOTE_ADDR") & vbCRLF strBody = strBody & "source URL: " & Request.ServerVariables ("HTTP_REFERER") & vbCRLF strBody = strBody & "hostname: " & Request.ServerVariables ("HTTP_HOST") & vbCRLF Set objMessage = Server.CreateObject("CDO.Message") objMessage.Subject = strSubject objMessage.Sender = strFrom objMessage.To = strTo objMessage.TextBody = strBody objMessage.Send Set objMessage = Nothing if strRedirect <> "" then response.redirect(CStr(strRedirect)) else Response.Write("
Message sent.
") end if end if Function BaseHost(host) Dim x, tempstring If InStr(host, "://") <> 0 Then host = Mid(host, InStr(host, "://")+3) End If host = strreverse(host) tmpstring = host x = Len(host) for y = x to 1 step -1 if mid(host, y, 1) = "/" Then tmpstring = mid(host, y+1) exit for end if next BaseHost = strreverse(tmpstring) End Function Function ValidateDomain(strRef) dim x ValidateDomain = false for each x in Hosts if x <> "" and Instr(1, strRef, x, 1) > 0 then ValidateDomain = true exit for end if next End Function Function IsEmail(sEmail) Dim regEx, retVal IsEmail = false Set regEx = New RegExp regEx.Pattern ="^[\w-\.]{1,}\@([\da-zA-Z-]{1,}\.){1,}[\da-zA-Z-]{2,3}$" regEx.IgnoreCase = true retVal = regEx.Test(sEmail) If not retVal Then exit function End If IsEmail = true End Function Function Allowed(ThisArray(), ThisString) Allowed = False for each x in ThisArray if LCase(ThisString)= LCase(x)then Allowed = True exit for end if next End Function Sub RebuildToString(Rcpt()) Dim x strTo = "" for each x in Rcpt if IsEmail(trim(x)) = True then strTo = strTo & trim(x) & ", " end if next x = Len(strTo) if x > 0 then strTo = Trim(strTo) strTo = ChopChar(strTo, ",") end if End Sub Function ChopChar(strString, strChar) Dim x x = Len(strString) if mid(strString, x) = strChar then ChopChar = mid(strString, 1, x -1) else ChopChar = strString end if End Function ' COPYRIGHT (C)(P) 2004 BY Paul R. Sadowski . ' ALL RIGHTS RESERVED. 'http://www.paulsadowski.com/WSH/psmail.htm %>