<%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.00 November 17 2001
'*********************************************************
const MailListKey="Registration"
Dim sAction, dbtable
Dim strPassword1, strPassword2
dim body
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
UpdateCustomer
SendMailToMerchant
WriteInfo
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")
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
'-----------------------------
' VP-ASP 6.00 Security Update
' 05/2006
'-----------------------------
dim doupdate, templastname,tempemail
OpenCustomerDb dbc
Set objRS = Server.CreateObject("ADODB.Recordset")
templastname=replace(strlastname,"'","''")
tempemail=replace(stremail,"'","''")
SQL = "SELECT * FROM " & dbtable & " WHERE "
whereok=""
sql=sql & whereok & " LastName='" & TempLastName & "'"
whereok = " AND "
SQL = SQL & whereok & " email='" & tempemail & "'"
'-----------------------------
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
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=LangMailListRegistration & " (" & 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)
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
%>