<%option explicit%>
<%
dim my_to, my_toaddress,my_system,my_from,my_fromaddress,my_subject,mailtype
dim mailer, my_attachment
dim customeradmin
'**********************************************************
' adds customer to mailling list
' Version 4.50 May 5, 2002
'*********************************************************
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 LangCustNotAllowed
end if
dbtable=getconfig("xmaillisttable")
Serror=""
If sAction = "" Then
ShopPageHeader
DisplayForm
ShopPageTrailer
Else
ValidateData()
if sError = "" Then
If unsubscribe="" then
UpdateCustomer
SendMailToMerchant LangMailListRegistration
WriteInfo
else
DoUnsubscribe
end if
else
ShopPageHeader
DisplayForm
ShopPageTrailer
end if
end if
Sub DisplayForm()
Displayerrors
response.write " " & getconfig("Xfont") & 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
Sub WriteInfo
ShoppageHeader
If getsess("customeradmin")="" then
response.write getconfig("xfont") & LangMailListinfomsg & " "
else
response.write getconfig("xfont") & "Details updated " & " "
end if
ShopPageTrailer
End Sub
Sub DisplayErrors
if sError<> "" then
response.write "" & getconfig("Xfont") & SError & ""
Serror=""
end if
end Sub
Sub UpdateCustomer
if getconfig("xMYSQL")="Yes" then
MYSQLMaillistUpdateCustomer
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
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 & LangPasswordMismatch & " "
else
if len(strPassword1) <6 then
Serror=Serror & 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 LangCustFirstname, "strfirstname", strFirstname,"No"
CreateCustRow LangCustLastname, "strLastname", strLastname,"Yes"
CreateCustRow LangCustEmail, "strEmail", strEmail, "Yes"
Response.Write(TableDefEnd)
CreateUnsubscribe
end sub
Sub ValidateMininumInfo
BlnMailList=TRUE
If strLastname = "" Then
sError = sError & LangCustLastname & LangCustRequired & " "
End If
If strEmail = "" Then
sError = sError & LangCustEmail & 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
end sub
sub CreateUnsubscribe
Response.Write(TableDef)
Response.Write tablerow
Response.write TableColumn
Response.write LangCustAdminRemove
Response.write TableColumnEnd
Response.write TableColumn
If unsubscribe<>"" then%>
<%Else%>
<%
End if
Response.write TableColumnend
Response.write TableRowend
Response.write ""
end sub
Sub DoUnsubscribe
RemoveCustomer
If serror="" Then
SendMailToMerchant LangCustAdminRemove
WriteInfo
exit sub
end if
ShopPageHeader
DisplayForm
ShopPageTrailer
end sub
Sub RemoveCustomer
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=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
end sub
%>