<%option explicit%> <% dim my_to, my_toaddress,my_system,my_from,my_fromaddress,my_subject,mailtype dim mailer, my_attachment dim customeradmin dim infomsg dim isubject '********************************************************** ' adds customer to mailling list ' Version 5.00 April 20, 2003 ' add authorized join and removed '********************************************************* const MailListKey="Registration" const MailUnsubscribekey="Remove" Dim sAction, dbtable Dim strPassword1, strPassword2 dim body, unsubscribe sAction=Request("Action") if saction="" then sAction=Request("Action.x") end if If getconfig("xAllowMailList")<>"Yes" then shoperror getlang("LangCustNotAllowed") end if dbtable=getconfig("xmaillisttable") Serror="" If sAction = "" Then ShopPageHeader DisplayForm ShopPageTrailer Else ValidateData() if sError = "" Then If unsubscribe="" then UpdateCustomer SendMailToMerchant getlang("LangMailListRegistration") WriteInfo else DoUnsubscribe end if else ShopPageHeader DisplayForm ShopPageTrailer end if end if Sub DisplayForm() Displayerrors shopwriteheader getlang("LangMailListMailPrompt") Response.Write("
") DisplayMinimumForm shopbutton Getconfig("xbuttoncontinue"), getlang("LangCommonContinue"),"action" response.write "
" ' End if customer table End Sub Sub ValidateData strFirstname = Request.Form("strFirstname") strLastname = Request.Form("strLastname") strEmail = Request.Form("strEmail") unsubscribe=request("blnmaillist") ValidateMininumInfo End Sub '***************************************************************************** ' Info msg has been set by correct routines '****************************************************************************** Sub WriteInfo ShoppageHeader response.write "
" & largeinfofont & infomsg & largeinfoend & "

" ShopPageTrailer End Sub Sub DisplayErrors if sError<> "" then shopwriteError SError Serror="" end if end Sub Sub UpdateCustomer if getconfig("xMYSQL")="Yes" then MYSQLMaillistUpdateCustomer HandleSubscribe exit sub end if dim dbc, whereok dim doupdate, templastname OpenCustomerDb dbc Set objRS = Server.CreateObject("ADODB.Recordset") templastname=replace(strlastname,"'","''") SQL = "SELECT * FROM " & dbtable & " WHERE " whereok="" sql=sql & whereok & " lastname='" & templastname & "'" whereok = " AND " SQL = SQL & whereok & " email='" & stremail & "'" objRS.open SQL, dbc, adOpenKeyset, adLockOptimistic, adcmdText 'debugwrite sql if not ObjRS.eof then DoUpdate="True" else objRs.close set objRS=nothing end if If Doupdate="" then Set objRS = Server.CreateObject("ADODB.Recordset") objRS.open dbtable, dbc, adOpenKeyset, adLockOptimistic, adCmdTable objRS.AddNew end if Updateminimuminfo objrs CloseRecordset objRS ShopCloseDatabase dbc HandleSubscribe end sub Sub HandleSubscribe dim isubject isubject="subscribe" If Getconfig("xmaillistauthorize")="Yes" then SendMailCustomer isubject, stremail, strfirstname, strlastname infomsg= getlang("langmaillistConfirm") & "
" else infomsg= getlang("LangMailListinfomsg") & "
" end if End sub ' Sub UpdateCustFieldXxx (fieldname,fieldvalue) on error resume next if fieldvalue="" then exit sub end if If getconfig("xdebug")="Yes" then Debugwrite fieldname & " " & fieldvalue & "
" end if objRS(fieldname)=fieldvalue end Sub Sub ValidatePassword Dim rc if ucase(getconfig("xpassword"))="YES" then if strPassword1<>"" then If StrPassword1<>strPassword2 then SError= SError & getlang("LangPasswordMismatch") & "
" else if len(strPassword1) <6 then Serror=Serror & getlang("LangPasswordLength") & "
" end if end if end if end if End sub Sub SendMailToMerchant (isubject) dim acount If getconfig("XMailListToMerchant")<>"Yes" then exit sub dim my_attachment, htmlformat htmlformat="Text" my_attachment="" mailtype=getconfig("xemailtype") my_from=strlastname my_fromaddress=stremail my_toaddress=getconfig("xemail") my_to=getconfig("xemailname") my_system=getconfig("xemailsystem") my_subject=isubject & " (" & strlastname & ")" Body=my_subject & vbcrlf body=body & shopdateformat(date(),getconfig("xdateformat")) & " " & time()& vbcrlf Body=Body & Strfirstname & " " & strLastname & vbcrlf Body=body & stremail & vbcrlf acount=0 ExecuteMail mailtype,My_from,my_fromaddress,my_to,my_toaddress,my_subject,body,htmlformat,my_attachment,acount If getconfig("xdebug")="Yes" then debugwrite "Mailing to: " & my_to & "(" & my_toaddress & ") from " & strlastname & " " & stremail end if end sub Sub DisplayMinimumForm Response.Write(TableDef) CreateCustRow getlang("LangCustFirstname"), "strfirstname", strFirstname,"No" CreateCustRow getlang("LangCustLastname"), "strLastname", strLastname,"Yes" CreateCustRow getlang("LangCustEmail"), "strEmail", strEmail, "Yes" Response.Write(TableDefEnd) CreateUnsubscribe end sub Sub ValidateMininumInfo If Getconfig("xmaillistauthorize")="Yes" then BlnMailList=0 else BlnMailList=TRUE end if If strLastname = "" Then sError = sError & getlang("LangCustLastname") & getlang("LangCustrequired") & "
" End If If strEmail = "" Then sError = sError & getlang("LangCustEmail") & getlang("LangCustrequired") & "
" Else CustomerValidateEmail stremail end If end sub ' Sub UpdateminimumInfo (objRS) If Strfirstname<>"" then objrs("firstname") = strfirstname end if objrs("lastname") = strlastname objRS("email")=stremail objRS("maillist")=blnMailList objrs("contactreason") = maillistkey objRS.Update strcustomerid=objrs("contactid") end sub sub CreateUnsubscribe Response.Write(TableDef) Response.Write tablerow Response.write TableColumn Response.write getlang("LangCustAdminRemove") Response.write TableColumnEnd Response.write TableColumn If unsubscribe<>"" then%> <%Else%> <% End if Response.write TableColumnend Response.write TableRowend Response.write "" end sub ' '***************************************************************** ' remove from mailing list '****************************************************************** Sub DoUnsubscribe RemoveCustomer If serror="" Then SendMailToMerchant getlang("LangCustAdminRemove") WriteInfo exit sub end if ShopPageHeader DisplayForm ShopPageTrailer end sub Sub RemoveCustomer If Getconfig("xmaillistauthorize")="Yes" then Isubject="remove" SendMailCustomer isubject, stremail, strfirstname, strlastname infomsg= getlang("LangMaillistConfirm") & "
" exit sub end if dim dbc, whereok, objrs,customerid dim doupdate, templastname templastname=replace(strlastname,"'","''") templastname=replace(templastname,"=","") OpenCustomerDb dbc SQL = "SELECT * FROM customers WHERE " whereok="" sql=sql & whereok & " lastname='" & templastname & "'" whereok = " AND " SQL = SQL & whereok & " email='" & stremail & "'" set objrs=dbc.execute(sql) if ObjRS.eof then Serror= getlang("LangLoginLocateFail") & "
" else customerid=objrs("contactid") end if closerecordset objrs If serror<>"" Then shopclosedatabase dbc exit sub end if sql="Update customers set maillist=0" sql=sql & ",contactreason='" & MailUnsubscribekey & " " & date() & "'" sql=sql & " where contactid=" & customerid dbc.execute(sql) shopclosedatabase dbc infomsg= getlang("LangMaillistremoved") & "
" end sub %>