%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("
"
' 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
%>