<%option explicit%> <% '********************************************************* ' Display customer, shipping forms form is now in shopcustomerform.asp ' Version 6.50 ' ' Nov 8, 2006 add email on registration HK ' Nov 11, 2006 HK don't allow gift certificates with other products ' Nov 28, 2006 HK Add Free products based on order amounts '********************************************************* Dim strPassword1, strPassword2, ShipMethodType Dim msg, newcust, Restorefromcookie Dim i, sAction, Oid, dbc, scartitem, arrCart, Length dim cookielogin, straffid, straffid1 Dim sbreadcrumb, spagename 'VP-ASP 6.50 - welcome email dim previouscustomerid dim My_system 'VP-ASP 6.50 - buy certain amount, get product free dim Nameincart ' Main Logic SetupCustomer setsess "form", "" If request("new")="yes" then ResetCustomerSessionData Setsess "customerlogincid","" SetSess "Login","" setsess "lastname","" cookielogin="No" setsess "form", "1" sbreadcrumb = getlang("langmaillistsubject") spagename = getlang("langmaillistsubject") elseif request("new")="no" then ResetCustomerSessionData Setsess "customerlogincid","" SetSess "Login","" setsess "lastname","" cookielogin="No" setsess "form", "" sbreadcrumb = getlang("langcommonlogin") spagename = getlang("langformatcustomerinformation") else If getsess("Login") = "" Then sbreadcrumb = getlang("langcommonlogin") Else sbreadcrumb = getlang("langformatcustomerinformation") spagename = getlang("langformatcustomerinformation") End If end if ' sAction=Request.form("Action") ' find out if we are being called via submit if saction="" then sAction=Request.form("Action.x") end if Serror=GetSess("Loginerror") ' possible mesage from login SetSess "Loginerror","" ' error from shop login If sAction = "" Then ' no came from customer logic If cookielogin<>"No" then Getcustomercookie end if Cookielogin="" GetGiftRegSessionData GetCustomerSessionData ' DisplayEverything ' Else sError="" ValidateData() ' need to validate anything, nothing is required If checkForExistingCustomer(strLastName, strEmail, strPassword1) then sError = sError & getlang("langCustomerExists") & "
" end if if sError = "" Then UpdateOrderInformation ' put in customer and order data SetSess "Login",strlastname 'VP-ASP 6.50 - when customer registers, they should be logged in as well if getconfig("xcustomerrequiresauthorization") <> "Yes" then setsess "customername", strfirstname GetCustomerSessionData dim tempshipmethodtype tempshipmethodtype = GetSess("Shipmethodtype") UpdateCustomerSessionData setsess "Shipmethodtype", tempshipmethodtype end if responseredirect GetSess("FollowonURL") else UpdateCustomerSessionData DisplayEverything end if end if ' End of main logic Sub DisplayEveryThing ShopPageHeader ' Normal page header if getconfig("xbreadcrumbs") = "Yes" then response.write "" end if If spagename <> "" Then Response.Write "

" & spagename & "

" & vbCrLf AddcopyAcross Displayerrors ' any input errors GetShippingDatabase ' get shipping database GetCustomerSessionData ' get customer info from session 'VP-ASP 6.09 - have option to use separate login form or inline login form If (GetSess("form")<>"1") and (GetSess("Login")="") and (Getsess("Lastname") = "") and (getconfig("xPromptForLogin") = "Yes") and (getconfig("xLoginSeparatePage") = "Yes") then AddLogin ' User login form else if getconfig("xLoginSeparatePage") <> "Yes" then AddLogin_Old end if DisplayForm ' display customer and shipping form end if ShopPageTrailer ' Normal page trailer end Sub ' Sub DisplayForm() 'VP-ASP 6.50 - if trying as a new customer, keep new customer flag on dim theaction if request.QueryString("New") > "" then Response.Write("

") else Response.Write("") end if AddInformationTable If GetSess("Login")<>"" and GetSess("Lastname")<>"" then addSubmitButton end if If getconfig("xshippingundercustomer")<>"Yes" then response.write "

" & vbCrLf end if ShopCustomerForm AddShippingForm ' in shopcustomerform.asp If getconfig("xshippingundercustomer")<>"Yes" then response.write "

" & vbCrLf end if ' comments ShopDeliverydate shopdeliverytime addaffiliate shopwriteheaderpic getlang("langCreate06"),"images/icons/note.gif" Response.write "

" Response.write "" Response.Write "

" Addlicense AddGiftCertificate AddDiscountCoupon AddOptionalStuff AddSubmitButton 'AddNewUser 'AddExistingUser AddWebSessForm Response.Write("") If getconfig("xshippingundercustomer")<>"Yes" then response.write "

" & vbCrLf end if End Sub ' Sub addShippingForm If getconfig("xshippingform")="No" and getconfig("xshippingselection")="No" then exit sub If Getconfig("xgiftregistry")="Yes" and getsess(REGISTRANTID)<>"" Then exit sub ShopShippingForm ' in shopcustomerform.asp 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")) 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")) strshipname = cleanchars(Request.Form("shipname")) strshipcompany = cleanchars(Request.Form("shipcompany")) strshipaddress = cleanchars(Request.Form("shipaddress")) strshiptown = cleanchars(Request.Form("shiptown")) strshipzip = cleanchars(Request.Form("shipzip")) strshipstate = cleanchars(Request.Form("shipstate")) strshipcountry = cleanchars(Request.Form("shipcountry")) strShipComment=cleanchars(request.form("shipcomment")) strPassword1 = cleanchars(Request.Form("strPassword1")) strPassword2 = cleanchars(Request.Form("strPassword2")) strgiftcertificate=cleanchars(request("strgiftcertificate")) strCoupon=cleanchars(request("strcoupon")) blnMailList=cleanchars(request("blnMaillist")) blncookiequestion=cleanchars(request("blncookiequestion")) If blncookiequestion="" then blncookiequestion=false else blncookiequestion=True end if strvatnumber=cleanchars(request("vatnumber")) strcustuserid=cleanchars(request.form("strcustuserid")) strhearaboutus= cleanchars(Request("hearaboutus")) strAddress2 = cleanchars(Request.Form("strAddress2")) strshipAddress2 = cleanchars(Request.Form("shipAddress2")) CustomerGetFields ' Get additional fields ShippingGetOtherFields ' 4.50 ValidateCustomerFields ShipMethodType= cleanchars(Request("ShipMethodType")) If ShipMethodType = getlang("langCommonSelect") Then sError = sError & getlang("langShippingError") & "
" End If strcustomertype=getsess("customertype") ValidatePassword ValidateGiftCertificate ValidateCustCoupon Validatelicense ValidateDeliverydateTime GetAffInfo if getsess("Login")="" then Validateusername strcustuserid, serror, rc ' In shopcustomer end if End Sub Sub AddOptionalStuff If getconfig("xPromptForOptional")="Yes" then Response.Write "

" shopwriteheader getlang("langCust02") Response.Write("") CreateCustRow getlang("langCustWebsite"), "strwebsite", strwebsite,"No" CreateCustRow getlang("langCustWorkphone"), "strWorkphone", strWorkPhone, "No" CreateCustRow getlang("langCustMobilephone"), "strMobilephone", strMobilePhone, "No" CreateCustRow getlang("langCustFax"), "strFax", strFax, "No" Response.Write("

") end if 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 CheckForDuplicate rc if rc > 0 then SError= SError & getlang("langPasswordDuplicate") & "
" end if else Serror=Serror & getlang("langPasswordLength") & "
" end if end if else if getsess("Login")="" then sError = sError & getlang("langpassword") & getlang("langCustRequired") & "
" end if end if If getconfig("xcustomeruserid")="Yes" then if getsess("Login")="" then If strcustuserid = "" Then sError = sError & getlang("langAdminusername") & getlang("langCustRequired")& "
" End If end if end if end if End sub Sub DisplayCart CartFormat "NO" ' format cart end sub Sub addLogin If GetSess("Login")<>"" and Getsess("Lastname") <>"" then exit sub end if If getconfig("xPromptForLogin")<>"Yes" then exit sub ShopLoginForm end sub Sub addLogin_old If GetSess("Login")<>"" and Getsess("Lastname") <>"" then exit sub end if If getconfig("xPromptForLogin")<>"Yes" then exit sub shopwriteHeader getlang("langCust01") ShopLoginForm_old end sub Sub DisplayErrors if sError<> "" then shopwriteError SError Serror="" end if end Sub Sub AddSubmitButton Response.Write "

" Shopbutton Getconfig("xbuttoncontinue"),trim(getlang("langCommonContinue")),"" Response.Write "

" end sub Sub CheckForDuplicate (rc) Dim testsql dim myconn dim rs OpenCustomerDb myconn dim tpassword, tlastname, tmail tlastname=replace(strlastname,"'","''") tpassword=replace(strpassword1,"'","") tmail=replace(stremail,"'","") sql = "select * from customers where lastname='" & tlastname & "' and password ='" & tpassword & "'" sql = sql & " and email='" & tmail & "'" 'debugwrite sql Set rs = myconn.Execute(SQL) If Not rs.EOF Then rc=4 else rc=0 end if rs.close shopclosedatabase myconn end sub Sub addnewUser response.write ("

" & getlang("langLogin02") & "

") end sub Sub addexistinguser response.write ("

" & getlang("langCommonLogin") & "

") end sub Sub addInformationTable response.write "

" & largeinfofont If GetSess("Login")="" then Response.Write getlang("langCustomerPrompt") & "
" end if If getconfig("xshippingform")="Yes" or getconfig("xshippingselection")="Yes" then 'VP-ASP 6.50 - hide this message if purchasing for a registry If getsess(REGISTRANTID)<>"" Then else shopwriteheader getlang("langShip01") & "
" & getlang("langShip02") end if end if Response.write largeinfoend & "

" end Sub ' Sub ValidateEmail If Not InStr(strEmail, "@") > 1 Then Serror=Serror & getlang("langInvalidEmail") & "
" end if End sub Sub CheckMinimumOrder Dim MinMessage dim MinimumOrder, ordertotal If GetSess("OrderProductTotal")="" then ordertotal=Getproductordertotal setsess "OrderProductTotal",ordertotal end if If getconfig("xMinimumOrder")<>"" then MinimumOrder=csng(getconfig("xMinimumOrder")) If GetSess("OrderProductTotal")< MinimumOrder then MinMessage = getlang("langMinimumOrder") & " " & shopformatcurrency(getconfig("xMinimumOrder"),getconfig("xdecimalpoint")) & " " shoperror MinMessage end if end if If getconfig("xMaximumOrder")<>"" then MinimumOrder=csng(getconfig("xMaximumOrder")) If GetSess("OrderProductTotal")> MinimumOrder then MinMessage = getlang("langMaximumOrder") & " " & shopformatcurrency(getconfig("xMaximumOrder"),getconfig("xdecimalpoint")) & " " shoperror MinMessage end if end if end sub ' Sub SetupCustomer ' ********************************************************************** ' Set defaults here '********************************************************************** dim rc SetSess "CurrentURL", "shopcustomer.asp" SetSess "FollowonURL","shopcustomer.asp" ' force login to come back to us Setsess "shipmessage","" 'SetSess "smprice","" ' no price ' Do database stuff if GetSess("CartCount")=0 or GetSess("CartCount")="" then shoperror getlang("langError01") end if if getsess("adminrestore")<>"" then responseredirect "shopa_createorder.asp" end if CheckGiftCertificate ' if gift certificate is being purchased CheckMinimumOrder VerifyDeliveryAddress rc If rc>0 then responseredirect "shopdeliveryaddress.asp" end if If getconfig("xproductdependentfield")<>"" then ShopProductDependent rc If rc>0 then shopdependentmessage serror shoperror serror end if end if 'VP-ASP 6.50 - buy certain amount get product free If getsess(REGISTRANTID)<>"" Then 'no free product else CartAddFreeProduct end if end sub ' adds to customer table, order table, oitems table Sub UpdateOrderInformation strDiscount=GetSess("CustDiscount") ' fix for discount if getconfig("xAllowCustomerUpdates")="Yes" or GetSess("Login")="" then 'VP-ASP 6.50 - welcome email previouscustomerid=getsess("customerid") ' if customerid exists then don't send mail UpdateContact end if strCustomerid=GetSess("Customerid") strDiscount=GetSess("CustDiscount") CorrectShippingFields UpdateCustomerSessionData Updatecookiedata Checkhacker 'VP-ASP 6.50 - welcome email Sendmailtocustomer strcustomerid SetSess "FollowonURL","shopcreateorder.asp" ' this is followon unless chnaged 'VP-ASP 6.50 - if setting up registry, don't set up shipping If getsess(REGISTRANTID)<>"" Then exit sub UpdateShippingSessionData ' update shipping date in session variables End Sub ' Sub AddGiftCertificate If getconfig("xGiftCertificates")<>"Yes" then exit sub 'VP-ASP 6.50 - hide gift cert option if creating registry If getsess(REGISTRANTID)<>"" Then exit sub shopwriteheaderpic getlang("langGiftEnter"),"images/icons/chest.gif" Response.Write "

" strGiftCertificate=Getsess("GiftCertificate") Response.Write("") CreateCustRow getlang("langGiftCertificate"), "strGiftcertificate", strgiftcertificate,"No" Response.Write(tableDefEnd) Response.Write "" end sub Sub AddDiscountCoupon strcoupon=getsess("coupon") If getconfig("xAllowCoupons")<>"Yes" then exit sub 'VP-ASP 6.50 - hide coupon option if creating registry If getsess(REGISTRANTID)<>"" Then exit sub shopwriteheaderpic getlang("langCustCouponPrompt"),"images/icons/money.gif" Response.Write "

" Response.Write("

") CreateCustRow getlang("langCouponDiscount"),"strCoupon",strCoupon,"" Response.Write(tableDefEnd) Response.Write "" end sub ' Sub ValidateGiftCertificate dim msg If getconfig("xGiftCertificates")<>"Yes" then exit sub SetSess "giftamountmax","" SetSess "giftamountused","" if strgiftcertificate="" then exit sub msg="" ShopvalidateGiftCertificate strgiftcertificate, msg If msg<>"" then Serror=SError & Msg & "
" strGiftCertificate="" end if end sub Sub ValidateCustCoupon dim msg, rc if strcoupon="" then exit sub LocateCoupon strcoupon, rc, msg if msg="" then CouponValidateSpecial strcoupon,msg if msg="" then SetSess "coupon",strcoupon else strcoupon="" SetSess "coupon",strcoupon Serror=SError & Msg & "
" end if else Serror=SError & Msg & "
" strCoupon="" SetSess "coupon",strcoupon end if end sub Function checkForExistingCustomer(LastName, emailvalue, passwordvalue) 'As Boolean Dim rs dim myconn dim templastname dim whereok dim blnCustomer 'As Boolean dim tempemailvalue, temppasswordvalue blnCustomer=False if sError<>"" then exit function If getconfig("xCheckexistingcustomer")<>"Yes" Then exit function if GetSess("Login")<>"" then exit function if lastname<>"" then templastname=replace(lastname,"'","''") end if tempemailvalue=replace(emailvalue,"'","") temppasswordvalue=replace(temppasswordvalue,"'","") ' See if customer stored separately OpenCustomerDb myconn sql = "select * from customers where " whereok="" If lastname<>"" then sql=sql & whereok & " lastname='" & templastname & "'" whereok = " AND " end if if emailvalue<> "" then SQL = SQL & whereok & " email='" & tempemailvalue & "'" end if 'If passwordvalue<>"" then ' SQL = SQL & " AND " & " password='" & temppasswordvalue & "'" 'end if 'debugwrite sql Set rs = myconn.Execute(SQL) If Not rs.EOF Then ResetCustomerSessionData blnCustomer=True else blnCustomer=False end if rs.close set rs=nothing ShopClosedatabase myconn checkForExistingCustomer=blnCustomer end Function Sub GetGiftregsessiondata if getconfig("xgiftregistry")<>"Yes" then exit sub If GetSess(REGISTRY) <> "" Then SetRegistryShippingInfo GetRegistryShippingInfo End If end sub Sub CorrectShippingFields If getconfig("Xshippingsetfields")<>"Yes" then exit sub Correctship strshipname,strfirstname & " " & strlastname correctship strshipcompany , strcompany correctship strshipaddress, straddress correctship strshiptown, strcity correctship strshipzip,strpostcode correctship strshipstate,strstate correctship strshipcountry, strcountry correctship strshipaddress2, straddress2 end sub Sub Correctship (shipfield, normfield) if shipfield<>"" then exit sub shipfield=normfield end sub '*********************************************************************** ' adds a license url to display '************************************************************************* Sub AddLicense dim blnlicense dim licenseurl 'VP-ASP 6.50 - precautionary security fix blnlicense=cleanchars(Request.Form("blnlicense")) If blnlicense="" then blnlicense=getsess("Licenseagreement") end if licenseurl=Getconfig("Xlicenseurl") If getconfig("Xlicenseagreement")<>"Yes" then exit sub If licenseurl="" then exit sub shopwriteheaderpic getlang("langLicenseAgreement"),"images/icons/license.gif" Response.Write "

" Response.Write("

") 'VP-ASP 6.50 - Change way license agreement displays 'Response.write TableColumn 'Response.Write "" 'Response.write "" & getlang("langLicenseAgreement") & "" Response.Write tablerow response.write "

" response.write "" Response.Write tablecolumnend Response.Write tablerowend Response.Write tablerow 'Response.write TableColumn response.write "

" Response.Write getlang("langlicenseagreementcheck") Response.Write tablecolumnend response.write "

" If blnlicense<>"" then%> <%Else%> <% End if response.write "

" 'VP-ASP 6.50 - add flag to order to say customer has agreed to terms setsess "blnlicense", blnlicense end Sub sub validatelicense if getconfig("xlicenseagreement")<>"Yes" then exit sub dim blnlicense 'VP-ASP 6.50 - precautionary security fix blnlicense=cleanchars(CBool(Request.Form("blnlicense"))) if not blnlicense then serror=serror & getlang("langlicenseforce") & "
" setsess "Licenseagreement","" else Setsess "Licenseagreement","Yes" end if end sub Sub Checkhacker dim rc, ipaddress If getconfig("xhackercheck")<>"Yes" then exit sub ipaddress=request.servervariables("REMOTE_ADDR") ShopCheckHacker stremail, ipaddress, strcountry, rc if rc> 0 then shoperror getlang("LangStorehacker") & " - " & rc end if end sub '************************************************************************ ' Update or resrt cookie '*********************************************************************** Sub Updatecookiedata If getconfig("xCookieLogin")<>"Yes" then exit sub If blnCookieQuestion then exit sub response.cookies("CartLogin").expires=date()-2 end sub ' '************************************************************************ ' Should affiliate info be generated in form '*********************************************************************** Sub Addaffiliate If getconfig("xaffcustomerform")<>"Yes" then exit sub dim affconn straffid=getsess("affid") If straffid<>"" then If isnumeric(straffid) then straffid=clng(straffid) end if end if Openaffiliatedb affconn shopwriteheaderpic getlang("LangAff"),"images/icons/affiliates.gif" Response.Write "

" Response.Write("") CreateCustRow getlang("LangAffID"),"straffid",straffid,"" Response.Write(tableRow & tablecolumn & "" & getlang("langaff") & tablecolumnend & "") Response.Write(tableDefEnd) Response.Write "" shopclosedatabase affconn end sub '******************************************************************** ' See what customer selected and check it if it was not from ' drop down list' '*********************************************************** Sub GetAffInfo If getconfig("xaffcustomerform")<>"Yes" then exit sub dim ars, asql, affconn straffid=request("straffid") straffid1=request("straffid1") 'VP-ASP 6.50 - precautionary security fix if not isnumeric(straffid) then straffid = "" end if if not isnumeric(straffid1) then straffid1 = "" end if If straffid1=getlang("langcommonselect") then straffid1="" end if if straffid="" and straffid1="" then exit sub end if If straffid1<>"" then straffid=straffid1 setsess "affid", straffid exit sub end if If not isnumeric(straffid) then straffid="" serror= serror & getlang("LangaffidInvalid") & "
" setsess "affid","" exit sub end if Openaffiliatedb affconn asql="select * from affiliates where affid=" & straffid set ars=affconn.execute(asql) if ars.eof then serror=serror & getlang("LangaffNotFound") & " " & straffid & "
" setsess "affid","" straffid="" else setsess "affid", straffid end if closerecordset ars shopclosedatabase affconn end sub '******************************************************************** ' VP-ASP 6.08 - Address2 is now copied across '*********************************************************** Sub AddCopyAcross%> <%End Sub '*************************************************************************** ' sends welcome email to customer' '************************************************************************** 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 If previouscustomerid<>"" then exit sub ' don't send duplicates 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 '*************************************************************************** 'is gift certificate being purchased with other products '*************************************************************************** sub Checkgiftcertificate dim cartcount, cartarray, giftid, productid, i cartcount = getsess("CartCount") ' number of products cartarray = getsessa("CartArray") giftid=getconfig("xGiftProductId") giftid=clng(giftid) if cartcount=1 then exit sub For i = 1 to cartcount productid=cartarray(cProductid,i) if clng(productid)=giftid then responseredirect "shopgiftverify.asp?option=checkout" end if next end sub %>

") GenerateTableV affconn,"affiliates","affid","company","lastname",straffid,"straffid1", "company", Getlang("langcommonselect") Response.Write("