<%option explicit%>
<%
const suppliertemplate="tmp_suppliermerchant.txt"
const secondemail=""
'*******************************************************
' Version 6.50 Supplier Registration
' Add email to merchant and own form
' Aug 5, 2004
'*******************************************************
const CountryRequired="No"
Dim strPassword1
Dim strPassword2
dim struserid, strsuppliername
Dim msg, newcust
Dim i
Dim sAction,login
dim rs
Dim newuser
dim my_to, my_toaddress,my_system,my_from,my_fromaddress,my_subject,mailtype
dim mailer, my_attachment
dim body
newuser=request("New")
if Newuser<>"" then
Setsess("supplierid"),""
end if
' the database can be used. If you don't display form
Dim dbc
' **********************************************************************
' Set defaults here
'**********************************************************************
SetSess "CurrentURL","shopsupplierregister.asp"
SetSess "FollowonURL","shopdisplaycategories.asp"
'
EditOpenDatabase dbc, database, "suppliers"
sAction=Request.form("Action") ' find out if we are being called via submit
if saction="" then
sAction=Request.form("Action.x") ' find out if we are being called via submit
end if
login=request("Login")
if login="" then
login=request("Login.x")
end if
if login<>"" then
struserid=request("struserid")
strpassword1=request("strpassword1")
'VP-ASP 6.08 - Remove any insecure characters from input
struserid=cleanchars(struserid)
strpassword1=cleanchars(strpassword1)
LocateSupplier struserid,strpassword1
if strsupplierid="" then
serror= getlang("LangLoginLocateFail") & " "
end if
end if
If sAction = "" Then ' no came from customer logic
DisplayEverything
Else
sError=""
ValidateData() ' need to validate anything, nothing is required
if sError = "" Then
UpdateSupplier
else
DisplayEverything
end if
end if
shopclosedatabase dbc
'
Sub DisplayEveryThing
ShopPageHeader ' Normal page header
if getconfig("xbreadcrumbs") = "Yes" then
response.write "
" & vbCrLf
Displayerrors ' any input errors
DisplayLoginForm() ' display customer
ShopPageTrailer ' Normal page trailer
end Sub
' adds to customer table, order table, oitems table
Sub UpdateOrderInformation
UpdateSupplier ' add customer to database
End Sub
Sub DisplayLoginForm()
AddLogin ' User login form
' Outside table
Response.Write("")
'AddNewUser
End Sub
Sub ValidateData()
'VP-ASP 6.50 - precautionary security fix
struserid=cleanchars(request.form("Struserid"))
strsupplierid=cleanchars(request.form("strSupplierid"))
strsuppliername=cleanchars(request.form("strSuppliername"))
strFirstname = cleanchars(Request.Form("strFirstname"))
strLastname = cleanchars(Request.Form("strLastname"))
strAddress = cleanchars(Request.Form("strAddress"))
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"))
'VP-ASP 6.08 - Remove any insecure characters from input
strpassword1=cleanchars(strpassword1)
struserid=cleanchars(struserid)
strsupplierid=cleanchars(strsupplierid)
strlastname=cleanchars(strlastname)
stremail=cleanchars(stremail)
If strSuppliername = "" Then
sError = sError & getlang("LangSuppliername") & getlang("LangCustRequired")& " "
End If
If struserid = "" Then
sError = sError & getlang("LangAdminUsername") & getlang("LangCustRequired")& " "
End If
SupplierValidateCustomerFields
ValidatePassword
end sub
Sub AddLogin
Response.Write(""
end sub
'
Sub ValidatePassword
Dim rc
If strPassword1 = "" Then
sError = sError & getlang("LangPassword") & "1" & getlang("LangCustRequired")& " "
exit sub
End If
If strPassword2 = "" Then
sError = sError & getlang("LangPassword") & "2" & getlang("LangCustRequired")& " "
exit sub
End If
If StrPassword1<>strPassword2 then
SError= SError & getlang("LangPasswordMismatch") & " "
exit sub
end if
if len(strPassword1) >= 6 then
CheckForDuplicate rc
if rc > 0 then
SError= SError & getlang("LangPasswordDuplicate") & " "
end if
else
Serror=Serror & getlang("LangPasswordLength") & " "
end if
End sub
Sub DisplayErrors
if sError<> "" then
shopwriteerror SError
Serror=""
end if
end Sub
'
Sub AddSubmitButton
Response.Write "
"
If Getconfig("xbuttoncontinue")="" Then
Response.Write("")
else
Response.Write("")
end if
Response.Write "
"
end sub
'
Sub CheckForDuplicate (rc)
Dim testsql
If GetSess("Supplierid")<>"" then
rc=0
exit sub
end if
SetSess "Login","Force"
SQL = "SELECT * FROM suppliers WHERE supplieruserid='" & struserid & "' AND supplierpassword ='" & strPassword1 & "'"
SQL = SQL & " AND Email='" & StrEmail & "'"
'debugwrite sql
Set rs = dbc.Execute(SQL)
If Not rs.EOF Then
rc=4
else
rc=0
end if
rs.close
end sub
'
Sub addInformationTable
response.write "
")
end sub
'
Sub ShopSupplierForm
'*******************************************************************
' Supplier form used in many places
' CreateCustRow is in shop$colors.asp
' Version 3.0
'********************************************************************
Shopsupplierform1
If strsupplierid<>"" then
Response.write ""
End if
end sub
'
Sub LocateSupplier (LastName, passwordvalue)
Dim rs
dim templastname
dim whereok
if lastname<>"" then
templastname=replace(lastname,"'","''")
end if
' See if customer stored separately
SQL = "SELECT * FROM suppliers WHERE "
whereok=""
If lastname<>"" then
sql=sql & whereok & " supplieruserid='" & TempLastName & "'"
whereok = " AND "
end if
If passwordvalue<>"" then
SQL = SQL & " AND " & " supplierpassword='" & passwordvalue & "'"
end if
'debugwrite sql
Set rs = dbc.Execute(SQL)
If Not rs.EOF Then
strsupplierid=rs("supplierid")
strsuppliername=rs("name")
setsess "supplierid",strsupplierid
struserid=rs("supplieruserid")
strfirstname = rs("firstname")
strlastname = rs("lastname")
straddress = rs("address")
strcity = rs("city")
strstate = rs("state")
strpostcode = rs("postcode")
strphone = rs("phone")
stremail = rs("email")
strfax = rs("fax")
if isnull(strfax) then strfax=""
strwebsite=rs("website")
if isnull(strwebsite) then strwebsite=""
strmobilephone=rs("mobilephone")
if isnull(strmobilephone) then strmobilephone=""
strworkphone=rs("workphone")
if isnull(strworkphone) then strworkphone=""
strcountry = rs("country")
if isnull(strcountry) then strcountry=""
strcompany = rs("company")
if isnull(strcompany) then strcompany=""
lnglogincount=rs("logincount")
strpassword1=rs("supplierpassword")
strpassword2=rs("supplierpassword")
else
strsupplierid=""
struserid=""
strpassword1=""
end if
rs.close
set rs=nothing
end sub
Sub UpdateSupplier
'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
MYSQLUpdateSupplier
exit sub
end if
Dim DoUpdate
DoUpdate=""
'on error resume next
If getsess("supplierid")<>"" then
strsupplierid=Getsess("Supplierid")
Set objRS = Server.CreateObject("ADODB.Recordset")
SQL="Select * from suppliers Where supplierid=" & strsupplierid
objRS.open SQL, dbc, adOpenKeyset, adLockOptimistic, adcmdText
if not ObjRS.eof then
DoUpdate="True"
objRS.update
else
objRs.close
set objRS=nothing
end if
end if
If Doupdate="" then
Set objRS = Server.CreateObject("ADODB.Recordset")
objrs.open "suppliers", dbc, adopenkeyset, adlockoptimistic, adcmdtable
objRS.AddNew
end if
objrs("supplieruserid")=struserid
objrs("name") = strsuppliername
updatesupplierfield "firstname",strfirstname
updatesupplierfield "lastname",strlastname
updatesupplierfield "address",straddress
updatesupplierfield "city",strcity
updatesupplierfield "state",strstate
updatesupplierfield "postcode",strpostcode
updatesupplierfield "country",strcountry
updatesupplierfield "company",strcompany
updatesupplierfield "phone",strphone
updatesupplierfield "workphone",strworkphone
updatesupplierfield "mobilephone",strmobilephone
updatesupplierfield "fax",strfax
updatesupplierfield "email",stremail
updatesupplierfield "website",strwebsite
updatesupplierfield "supplierpassword",strpassword1
objrs.update
if doupdate="" then
sendmail objrs
end if
strsupplierid=cstr(objrs("supplierid")) 'version 2.4
setsess "supplierid",strsupplierid
objrs.close ' version 2.4
set objrs=nothing
writeinfomessage
end sub
Sub UpdateSupplierField (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 WriteInfoMessage
ShopPageHeader
if getconfig("xbreadcrumbs") = "Yes" then
response.write "
")
end sub
Sub SendMail (objrs)
If Getconfig("xsuppliermailregistration")<>"Yes" then exit sub
dim emailformat, acount, template
' objRs has the current supplier record
template=getconfig("xsupplierregistermerchant")
If template="" then
exit sub
end if
If template<>"" then
FormatOtherMail template, objRS, Body
Setupemailformat template, emailformat
mailtype=getconfig("xemailtype")
my_from=strFirstname & " " & strLastname
my_fromaddress=stremail
my_toaddress=getconfig("xemail")
my_to=getconfig("xemailname")
my_system=getconfig("xemailsystem")
my_subject="Supplier Registration"
acount=0
ExecuteMail mailtype,My_from,my_fromaddress,my_to,my_toaddress,my_subject,body,emailformat,my_attachment, acount
If Secondemail<>"" then
my_toaddress=secondemail
ExecuteMail mailtype,My_from,my_fromaddress,my_to,my_toaddress,my_subject,body,emailformat,my_attachment, acount
end if
end if
' Now send to affiliate
template=getconfig("xsupplierregistertemplate")
If template<>"" then
FormatOtherMail template, objRS, Body
Setupemailformat template, emailformat
mailtype=getconfig("xemailtype")
my_from=getconfig("xemailname")
my_fromaddress=getconfig("xemail")
my_toaddress=strEmail
my_to=strFirstname & " " & strLastname
my_system=getconfig("xemailsystem")
my_subject="Supplier Registration"
acount=0
ExecuteMail mailtype,My_from,my_fromaddress,my_to,my_toaddress,my_subject,body,emailformat,my_attachment,acount
end if
end sub
Sub ShopSupplierForm1
'*******************************************************************
' Customer form used in many places
' CreateCustRow is in shop$colors.asp
' Version 4.50 April 20, 2002 add vat number
' ShippingOtherfields
'********************************************************************
shopwriteheaderpic getlang("langcommoninformation"), "images/icons/user.gif"
Response.Write "
"
Response.Write(TableDef)
CreateCustRow getlang("LangCustFirstname"), "strfirstname", strFirstname,"Yes"
CreateCustRow getlang("LangCustLastname"), "strLastname", strLastname,"Yes"
CreateCustRow getlang("LangCustAddress"), "strAddress", strAddress,"Yes"
CreateCustRow getlang("LangCustCity"), "strCity", strCity,"Yes"
If getconfig("xPromptForState")="Yes" then
If getconfig("xIncludeStates")="Yes" Then
Response.Write(tableRow & "
")
else
CreateCustRow getlang("LangCustState"), "strState", strState,"Yes"
end if
end if
CreateCustRow getlang("langCustPostCode"), "StrPostcode", strPostCode,"Yes"
CreateCustRow getlang("LangCustPhone"),"strPhone", strPhone, "Yes"
CreateCustRow getlang("LangCustEmail"), "strEmail", strEmail, "Yes"
If getconfig("xPromptForCountry")="Yes" then
If getconfig("xIncludeCountries")="Yes" Then
If getconfig("xCountryRequired")="Yes" then
Response.Write(tableRow & "
" & "* " & getlang("langCustCountry") & "
" & "
")
Else
Response.Write(tableRow & "
" & getlang("langCustCountry") & "
" & "
")
End if
'VP-ASP 6.50 - extra parameter for shopcountries
ShopCountries "StrCountry", strCountry,"no"
Response.Write("
")
else
If getconfig("xCountryRequired")="Yes" then
CreateCustRow getlang("LangCustCountry"), "strCountry", strCountry,"Yes"
Else
CreateCustRow getlang("LangCustCountry"), "strCountry", strCountry,"No"
End if
end if
end if
CreateCustRow getlang("LangCustCompany"), "strCompany", strCompany,"No"
If getconfig("xvatnumber")="Yes" then
CreateCustRow getlang("LangVatnumber"),"vatnumber", strvatnumber,"No"
end if
Response.Write(TableDefEnd)
Response.Write "
"
end sub
Sub SupplierValidateCustomerFields
If strFirstname = "" Then
sError = sError & getlang("langCustFirstname") & getlang("langCustRequired") & " "
End If
If strLastname = "" Then
sError = sError & getlang("langCustLastname") & getlang("langCustRequired") & " "
End If
If strAddress = "" Then
sError = sError & getlang("langCustAddress") & getlang("langCustRequired") & " "
End If
If strCity = "" Then
sError = sError & getlang("langCustCity") & getlang("langCustRequired") & " "
End If
If getconfig("xIncludeStates")="Yes" and strState="??" then
strstate=""
end if
If getconfig("xstaterequired")="Yes" then
If getconfig("xPromptForState")="Yes" then
If strState = "" Then
sError = sError & getlang("langCustState") & getlang("langCustRequired") & " "
End If
end if
end if
If strPostCode = "" Then
sError = sError & getlang("langCustPostCode") & getlang("langCustRequired") & " "
End If
If strPhone = "" Then
sError = sError & getlang("langCustPhone") & getlang("langCustRequired") & " "
End If
If strEmail = "" Then
sError = sError & getlang("langCustEmail") & getlang("langCustRequired") & " "
Else
CustomerValidateEmail stremail
end If
If getconfig("xCountryRequired")="Yes" then
If strCountry="" or strCountry="??" then
sError = sError & getlang("langCustCountry") & getlang("langCustRequired") & " "
End If
end if
end sub
%>