<%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 Register
' Version 6.50 March 26, 2004
'*********************************************************
const MailListKey="Registration"
Dim sAction, dbtable
Dim strPassword1, strPassword2
dim body
InitializeSystem
sAction=Request("Action")
if saction="" then
sAction=Request("Action.x")
end if
dbtable="customers"
If getconfig("xAllowCustomerRegister")<>"Yes" then
shoperror getlang("LangCustNotAllowed")
end if
Serror=""
If sAction = "" Then
ShopPageHeader
if getconfig("xbreadcrumbs") = "Yes" then WriteCustRegBreadcrumb
Response.Write "" & getlang("langmaillistsubject") & "
"
DisplayForm
ShopPageTrailer
Else
ValidateData()
if sError = "" Then
UpdateCustomer
SendMailToMerchant
'VP-ASP 6.50 - welcome email
SendmailtoCustomer strcustomerid
'VP-ASP 6.50 - when customer registers, they should be logged in as well
if getconfig("xcustomerrequiresauthorization") <> "Yes" then
UpdateCustomerSessionData
setsess "customername", strfirstname
SetSess "Login",strlastname
end if
WriteInfo
else
ShopPageHeader
if getconfig("xbreadcrumbs") = "Yes" then WriteCustRegBreadcrumb
Response.Write "" & getlang("langmaillistsubject") & "
"
DisplayForm
ShopPageTrailer
end if
end if
Sub DisplayForm()
Displayerrors
setsess "login","" ' force customer out
shopwriteheader getlang("LangMailListMailPrompt")
Response.Write(""
' End if customer table
End Sub
Sub ValidateData
dim rc
'VP-ASP 6.50 - precautionary security fix
strFirstname = cleanchars(Request.Form("strFirstname"))
strLastname = cleanchars(Request.Form("strLastname"))
strAddress = cleanchars(Request.Form("strAddress"))
'VP-ASP 6.09 - address 2 wasn't being saved
strAddress2 = cleanchars(Request.Form("strAddress2"))
strCity = cleanchars(Request.Form("strCity"))
strState = cleanchars(Request.Form("strState"))
strPostCode = cleanchars(Request.Form("strPostCode"))
strCountry = cleanchars(Request.Form("strCountry"))
strCompany = cleanchars(Request.Form("strCompany"))
strWebsite = cleanchars(Request.Form("strWebsite"))
strPhone = cleanchars(Request.Form("strPhone"))
strWorkphone = cleanchars(Request.Form("strWorkphone"))
strMobilephone = cleanchars(Request.Form("strMobilephone"))
strFax = cleanchars(Request.Form("strFax"))
strEmail = cleanchars(Request.Form("strEmail"))
strPassword1 = cleanchars(Request.Form("strPassword1"))
strPassword2 = cleanchars(Request.Form("strPassword2"))
strcustuserid = cleanchars(Request.Form("strcustuserid"))
blnMailList=cleanchars(request("blnMaillist"))
'VP-ASP 6.50 - add support for MYSQL
if ucase(xdatabasetype) = "MYSQL" OR ucase(xdatabasetype) = "MYSQL351" then
If blnMailList="" then blnMailList="0"
else
If blnMailList="" then blnMailList="False"
end if
strhearaboutus=cleanchars(request("hearaboutus"))
CustomerGetFields
ValidateCustomerFields
ValidatePassword
ValidateUsername strcustuserid, serror, rc
End Sub
Sub WriteInfo
ShoppageHeader
if getconfig("xbreadcrumbs") = "Yes" then WriteCustRegBreadcrumb
If getsess("customeradmin")="" then
Response.Write "" & getlang("LangMailListinfomsg") & "
"
else
Response.Write "" & getlang("LangEdit03") & "
"
end if
ShopPageTrailer
End Sub
Sub DisplayErrors
if sError<> "" then
shopwriteError SError
Serror=""
end if
end Sub
Sub UpdateCustomer
'VP-ASP 6.50 - broadened defintion of IF statement to cover cases where xmysql hasn't been set
if ucase(xdatabasetype) = "MYSQL" OR ucase(xdatabasetype) = "MYSQL351" OR getconfig("xMYSQL")="Yes" then
MYSQLMaillistUpdateCustomer
exit sub
end if
dim dbc, whereok
dim doupdate, templastname, tempemail
OpenCustomerDb dbc
Set objRS = Server.CreateObject("ADODB.Recordset")
'VP-ASP 6.08 - clean invalid characters from strings
templastname=replace(strlastname,"'","''")
templastname=cleanchars(templastname)
tempemail=replace(stremail,"'","''")
tempemail=cleanchars(tempemail)
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
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
objrs("firstname") = strfirstname
objrs("lastname") = strlastname
objrs("address") = straddress
'VP-ASP 6.09 - address2 wasn't being saved
objrs("address2") = straddress2
objrs("city") = strcity
objrs("state") = strstate
objrs("postcode") = strpostcode
objrs("country") = strcountry
objrs("company") = strcompany
objrs("phone") = strphone
' objrs("workphone") = strworkphone
' objrs("mobilephone") = strmobilephone
objrs("fax") = strfax
objrs("email") = stremail
objrs("maillist")=blnmaillist
updatecustfieldxxx "password", strpassword1
updatecustfieldxxx "userid", strcustuserid
updatecustfieldxxx "hearaboutus", strhearaboutus
objrs("contactreason") = maillistkey
CustomerUpdateFields objrs
objRS.Update
strcustomerid=objrs("contactid")
CloseRecordset objrs
ShopCloseDatabase dbc
SetSess "customerid", strCustomerID
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
else
sError = sError & getlang("LangCustomerPassword") & getlang("LangCustrequired") & "
"
End if
If getconfig("xcustomeruserid")="Yes" then
If strcustuserid = "" Then
sError = sError & getlang("LangAdminusername") & getlang("LangCustrequired") & "
"
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= getlang("LangMailListRegistration") & " (" & strcustomerid & ")"
Body=my_subject & vbcrlf
body=body & shopdateformat(date(),getconfig("xdateformat")) & " " & time()& vbcrlf
Body=Body & Strfirstname & " " & strLastname & vbcrlf
body=body & strAddress & vbcrlf
body=body & strCity & " " & strState & " " & strpostcode & vbcrlf
body=body & strCountry & vbcrlf
Body=body & strPhone & 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
'*********************************************************************************
' Mail to customer on registration
' Author Howaard Kadetz
' Nov 8, 2006
'*********************************************************************************
Sub Sendmailtocustomer (customerid)
dim body, mailtype, my_from, my_fromaddress, my_to, my_toaddress, my_subject
dim acount, emailformat, my_attachment
dim template, custdbc, sql, objrs
If getconfig("xwelcomeemail")<>"Yes" then exit sub
'debugwrite "Doing email"
opencustomerdb custdbc
sql="select * from customers where contactid=" & customerid
set objrs=custdbc.execute(sql)
If objrs.eof then
closerecordset objrs
shopclosedatabase custdbc
exit sub
end if
template=getconfig("xwelcomeemailtemplate")
mailtype=getconfig("xemailtype")
my_from=getconfig("xemailname")
my_fromaddress=getconfig("xemail")
my_toaddress=objrs("email")
my_to=objrs("firstname") & " " & objrs("lastname")
my_system=getconfig("xemailsystem")
my_subject= getlang("LangMailListRegistration")
acount=0
FormatOtherMail template, objRS, Body
Setupemailformat template, emailformat
mailtype=getconfig("xemailtype")
closerecordset objrs
shopclosedatabase custdbc
ExecuteMail mailtype,My_from,my_fromaddress,my_to,my_toaddress,my_subject,body,emailformat,my_attachment, acount
end sub
Sub WriteCustRegBreadcrumb()
response.write ""
End Sub
%>