<%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 4.00a April 13, 2002 Fix password
'*********************************************************
const MailListKey="Registration"
Dim sAction, dbtable
Dim strPassword1, strPassword2
dim body
sAction=Request("Action")
if saction="" then
sAction=Request("Action.x")
end if
dbtable="customers"
If getconfig("xAllowCustomerRegister")<>"Yes" then
shoperror LangCustNotAllowed
end if
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")
strAddress = Request.Form("strAddress")
strCity = Request.Form("strCity")
strState = Request.Form("strState")
strPostCode = Request.Form("strPostCode")
strCountry = Request.Form("strCountry")
strCompany = Request.Form("strCompany")
strWebsite = Request.Form("strWebsite")
strPhone = Request.Form("strPhone")
strWorkphone = Request.Form("strWorkphone")
strMobilephone = Request.Form("strMobilephone")
strFax = Request.Form("strFax")
strEmail = Request.Form("strEmail")
strPassword1 = Request.Form("strPassword1")
strPassword2 = Request.Form("strPassword2")
blnMailList=request("blnMaillist")
If blnMailList="" then blnMailList="False"
CustomerGetFields
ValidateCustomerFields
ValidatePassword
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,"'","''")
'------------------------------------
' VP-ASP Security Patch - 02/2006
'------------------------------------
templastname=cleanchars(templastname)
'------------------------------------
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
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
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
'------------------------------------
' VP-ASP Security Patch - 02/2006
'------------------------------------
objRS("Email") = cleanchars(strEmail)
'------------------------------------
objRS("maillist")=blnMailList
UpdateCustFieldxxx "Password", strpassword1
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 & LangPasswordMismatch & "
"
else
if len(strPassword1) <6 then
Serror=Serror & LangPasswordLength & "
"
end if
end if
else
sError = sError & LangCustomerPassword & LangCustRequired & "
"
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 & " (" & 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
%>