<%@ Language=VBScript %> <% '************************************************************************* ' DO NOT MODIFY THIS SCRIPT IF YOU WANT UPDATES TO WORK! ' Function : This script handles all the shopping cart functions namely... ' : - Add item to cart ' : - Delete item from shopping cart ' : - Recalculate shopping cart totals ' : - View shopping cart ' Product : CandyPress Store Frontend ' Version : 6.2 ' Modified : December 2006 ' Copyright: Copyright (C) 2010 Cavallo Communications, LLC. ' See "license.txt" for this product for details regarding ' licensing, usage, disclaimers, distribution and general ' copyright requirements. If you don't have a copy of this ' file, you may request one at http://www.candypress.com '************************************************************************* ' Date Description ' 10/17/05 Corrected code so that cart message would be displayed. ' 12/03/05 Added support for store wide discount (StoreWide) ' 12/20/05 Fixed store wide discount support - broke discounts. ' 01/07/06 Fixed error with cartmsg display for other languages ' 01/13/06 Fixed cart display when small image is displayed in cart. ' 06/15/06 Made changes to how Exchange is called to make calculation better. ' 12/07/06 Added Google checkout from the cart ' 09/07/07 Fixed SubTotal stored in cart head - was not in the stores default currency ' 09/11/07 Added return URL for option inventory when inventory exceeded. ' 09/11/07 Change order of checking for required options and inventory ' 09/11/07 Fixed getOptionInventory to work on cart recalc. ' 09/28/07 Changed to use getUserAddress to retrieve IP ' 11/15/07 Remove extranous include of usermods/_INCcart_.asp ' 06/03/09 Added code for affiliate id entry in the cart ' 06/09/08 Added code to return to last displayed category page and sortorder ' 10/04/08 Added code to set DL password for ESD items ' 12/23/09 Added code to support gift certificates ' 01/08/09 Added code to support product recommendations ' 01/12/09 Added product discount exempt flag and support ' 02/16/09 Added support for a minimum product quantity ' 03/02/09 Removed support for gift certifiates - moved to 40_submitorder.asp ' 05/19/09 Fixed min order check ' 08/16/09 Fixed cart product recommendation ' 11/18/09 Fixed update SQL statement for option inventory items ' 12/05/09 Fixed error with currency change. ' 02/07/10 Removed tables added div - candythemes.com '************************************************************************* Option explicit Response.Buffer = true 'Work Fields dim action 'What type of action the script must take dim subaction dim errMsg 'Error message when adding, deleting, updating dim errorMsgDisc 'Error message when updating order discount dim f, i 'Indexes dim newQuantity 'New item quantity (used when updating qty) dim oldQuantity 'Old Item quantity (used when updating qty) dim cartMsg 'Message that will be display on the cart dim idCategory 'Category Product is in dim deletedItems 'return from saved order dim imageURL 'small Image URL dim returnURL dim qIdOrder dim msg dim curPage 'current listing page dim sortField 'current sort field dim checkboxArray 'used to split check box items dim userroles dim wholesaleprice dim code dim remaining dim errorMsgGift dim giftcode dim page dim used dim pagerefer 'cartHead dim orderStatus dim orderDate dim subTotal dim taxTotal dim shipmentTotal dim handlingFeeTotal dim otherFeeTotal dim Total dim Name dim LastName dim CustomerCompany dim Phone dim Email 'dim Address dim City dim Zip dim locState dim locCountry dim cardType dim cardNumber dim cardExpMonth dim cardExpYear dim cardName dim cardVerify dim paymentType dim shipmentMethod dim idAffiliate 'products dim minorder 'discount dim discCode dim discPerc dim discTotal 'cartRows dim IDCartRow dim IDProduct dim SKU dim quantity dim unitPrice dim unitWeight dim description dim taxExempt dim discAmt dim dlpassword dim discExempt dim discBasis 'cartRowsOptions dim idOption dim optionPrice dim optionWeight dim optionDescrip dim optionTaxExempt 'products dim stock dim handlingfee dim filename 'optionsGroups dim optionType 'options dim priceToAdd dim percToAdd 'DiscOrder dim idDiscOrder dim discFromAmt dim discToAmt 'DiscProd dim idDiscProd dim discFromQty dim discToQty 'Database dim mySQL dim conntemp dim rs dim rstemp dim rstemp2 'Session dim idOrder dim idCust %> <% '************************************************************************* 'Open Database Connection call openDb() 'Store Configuration if loadConfig() = false then call errorDB(LangText("ErrConfig",""),"") end if %> <% if uCase(StoreAdminInstalled) = "Y" and pGoogle = "-1" then %> <% end if if uCase(StoreAdminInstalled) = "Y" and pPayPalPro = "-1" then %> <% end if 'Get/Set Cart/Order Session idOrder = sessionCart() 'Get/Set Customer Session idCust = sessionCust() minorder = 1 deletedItems = trim(validHTML(Request.querystring("deletedItems"))) 'Determine Action to be taken action = lCase(Request.Form("action")) if len(action) = 0 then action = lCase(validHTML(Request.QueryString("action"))) end if action = lCase(action) 'Get subaction subaction = trim(Request.QueryString("subaction")) if len(subaction) = 0 then subaction = trim(Request.Form("subaction")) end if subaction = lCase(subaction) if action = "googlecheckout" and pGoogle = "-1" then payGoogle end if 'Add item to cart if action = "additem" then addItem() else 'Check that the session is still active if isNull(idOrder) then errMsg = LangText("ErrCartEmpty","") else 'Delete item from cart if action = "delitem" then delItem() end if 'Recalculate cart totals if action = "recalc" then reCalc() end if end if end if 'Check for errors after updates if len(trim(errMsg)) <> 0 then call closeDB() if len(returnURL) = 0 then Response.redirect "sysMsg.asp?errMsg=" & server.URLEncode(errMsg) else Response.redirect "sysMsg.asp?errMsg=" & server.URLEncode(errMsg) & "&returnURL=" & server.URLEncode(returnURL) end if end if 'Check that the cart still has at least 1 item after updates if cartQty(idOrder) = 0 then errMsg = LangText("ErrCartEmpty","") call closeDB() Response.redirect "sysMsg.asp?errMsg=" & server.URLEncode(errMsg) end if 'If any updates were made to the order, re-check and re-calculate 'the Order Discount. 'if action = "additem" or action = "delitem" or action = "recalc" then orderDisc() 'if action <> "recalc" then orderCert() 'end if %> <% ' if this is an order entry action if action = "additem" and subaction = "oe" then response.redirect AdminSSl & "sa_oe.asp?action=oe" end if 'Redirect back to category page immediately after add... if action = "additem" and quickAdd = "-1" then idCategory = getProdLastCategory(idProduct) if len(idCategory) > 0 then errMsg = LangText("GenAddedProduct","Product added to cart.") call closeDB() 'Response.Redirect "prodView.asp?idProduct=" & idProduct & "&Msg=" & errMsg if Request.Form("refpage") = "productlist.asp" then Response.Redirect "prodList.asp?idCategory=" & idCategory & "&curPage=" & curPage & "&sortField=" & sortField & "&Msg=" & errMsg else Response.Redirect "prodView.asp?idProduct=" & idProduct & "&Msg=" & errMsg end if else errMsg = LangText("GenAddedProduct","Product added to cart.") call closeDB() Response.Redirect "prodView.asp?idProduct=" & idProduct & "&Msg=" & errMsg end if end if 'Close Database Connection call closeDB() '************************************************************************* ' Add item to cart '************************************************************************* sub addItem() 'Declare variables local to this subroutine dim reqOptSel 'Used when checking for "required" options dim arrOptions 'Array - Options from FORM - ID dim arrOptionsTXT 'Array - Options from FORM - Text Input dim arrOptionsDB 'Array - Options in DB - ID dim arrOptionsDBTXT 'Array - Options in DB - Description errMsg = "" 'Validate Product ID IDProduct = Request.Form("idProduct") if len(IDProduct) = 0 then IDProduct = Request.QueryString("idProduct") end if if not isNumeric(IDProduct) then errMsg = LangText("ErrInvProdID","") exit sub end if 'Get Product info from the database mySQL = "SELECT description,price,wholesaleprice,sku,stock,weight,taxExempt,handlingfee,filename, discExempt, minorder " _ & "FROM " & tablePrefix & "products " _ & "WHERE idProduct = " & validSQL(idProduct,"I") & " " _ & "AND active = -1" set rsTemp = openRSexecute(mySQL) if rstemp.eof then errMsg = LangText("ErrInvProdID","") exit sub else Description = rstemp("description") unitPrice = rstemp("price") SKU = rstemp("sku") stock = rstemp("stock") unitWeight = rstemp("weight") taxExempt = UCase(trim(rstemp("taxExempt"))) handlingFee = rstemp("handlingfee") filename = rsTemp("filename") wholesaleprice = rsTemp("wholesaleprice") discExempt = rsTemp("discExempt") minorder = rsTemp("minorder") end if if len(minorder) = 0 or IsNull(minorder) then minorder = 1 end if if lCase(sku) = "cert" then 'Use passed certificate price and validate unitprice = Request.Form("certprice") if (NOT IsNumeric(unitprice)) or (unitprice < 0) or (CDbl(unitprice) > CDbl(pMaxCert)) or(CDbl(unitprice) < CDbl(pMinCert)) or ((unitprice mod pIncrCert) > 0) then errMsg = LangText("ErrInvProdID","") exit sub end if end if call closeRS(rsTemp) idCust = sessionCust() if Not IsNull(idCust) then userroles = session(storeID & "userroles") if (CInt(userroles) and CInt(WHOLESALER)) then if unitprice > wholesaleprice then unitprice = wholesaleprice end if end if 'Check if there is a file name for ESD and if so generate the dlpassword 'The dlpassword is used for all ESD products ordered in this session if len(filename) > 0 then if len(session("dlpassword")) = 0 then session("dlpassword") = right(rndkey(9999999),dlPasswordLength) end if dlpassword = session("dlpassword") end if 'Check that mandatory options were selected for each f in Request.Form if lCase(left(f,11)) = "reqidoption" then if Request.Form(f) = "Y" then optionType = Request.Form("TYP" & mid(f,4)) if (optionType = "S" and Request.Form("OPT" & mid(f,4)) = "") _ or (optionType = "R" and Request.Form("OPT" & mid(f,4)) = "") _ or (optionType = "C" and Request.Form("OPT" & mid(f,4)) = "") _ or (optionType = "T" and Request.Form("TXT" & mid(f,4)) = "") then errMsg = LangText("ErrReqOpt","") & "'" & Request.Form("DES" & mid(f,4)) & "'." returnURL = "prodView.asp?idProduct=" & idProduct exit sub end if end if end if next 'Validate Quantity Quantity = Request.Form("quantity") if len(Quantity) = 0 then Quantity = 1 end if if not quantityValid(quantity,stock,idProduct) then exit sub end if 'Check if new qty plus existing qty exceeds max for cart if Quantity + cartQty(idOrder) > pMaxCartQty then errMsg = LangText("ErrMaxOrdQty","") exit sub end if 'Get selected options and place them in arrays for later use arrOptions = "" arrOptionsTXT = "" for each f in Request.Form if lCase(left(f,11)) = "optidoption" then 'Create an array of selected option ID's and another array of user entered text optionType = Request.Form("TYP" & mid(f,4)) if isNumeric(Request.Form(f)) _ and (optionType = "S" _ or optionType = "R" _ or (optionType = "T" and Request.Form("TXT" & mid(f,4)) <> "")) then 'Append delimiter to array string if len(arrOptions) > 0 then arrOptions = arrOptions & "*,*" arrOptionsTXT = arrOptionsTXT & "*,*" end if 'Append values to array string. arrOptions = arrOptions & Request.Form(f) if len(trim(Request.Form("TXT" & mid(f,4)))) = 0 then arrOptionsTXT = arrOptionsTXT & " " 'Prevent empty array else arrOptionsTXT = arrOptionsTXT & validHTML(Request.Form("DES" & mid(f,4))) & " : " & validHTML(Request.Form("TXT" & mid(f,4))) end if else if(optionType = "C") then ' split the checkbox values into an array checkboxArray = split(Request.Form(f),",") if ( Not IsEmpty(checkboxArray)) then for i = 0 to Ubound(checkboxArray) if len(arrOptions) > 0 then arrOptions = arrOptions & "*,*" arrOptionsTXT = arrOptionsTXT & "*,*" end if arrOptions = arrOptions & Trim(checkboxArray(i)) arrOptionsTXT = arrOptionsTXT & " " 'Prevent empty array next end if end if end if end if next arrOptions = split(arrOptions ,"*,*") arrOptionsTXT = split(arrOptionsTXT,"*,*") 'Get the return parameters curPage = Request.Form("curPage") if len(curPage) = 0 or not IsNumeric(curPage) then curPage = 1 end if sortField = Request.Form("sortField") select case sortField case "description" case "price" case "sortorder" case "sku" case "" case else errMsg = LangText("ErrInvalidSort","Invalid Sort Order") exit sub end select idCategory = Request.Form("idCategory") if len(idCategory) = 0 or not IsNumeric(idCategory) then idCategory = 1 'All Categories end if %> <% 'Notes : '1. To allow the use of BeginTrans and CommitTrans, the cursor ' location must be on the client (adUseClient). '2. To retrieve the @@identity (AutoNumber) value of the inserted ' record, the cursor location must be on the server. 'Set CursorLocation of the Connection Object to Client connTemp.CursorLocation = adUseClient 'BEGIN Transaction connTemp.BeginTrans 'If no cart exists, create new cart and session. if isNull(idOrder) then set rsTemp = openRSopen(tablePrefix & "cartHead",adUseServer,adOpenKeySet,adLockOptimistic,adCmdTable,0) rsTemp.AddNew 'Update standard fields rsTemp("idCust") = sessionCust() rsTemp("orderDate") = currDateTime("DT",timeOffSet) rsTemp("orderDateInt") = dateInt(currDateTime("DT",timeOffSet)) rsTemp("orderStatus") = uCase(genStatUnfinal) rsTemp("auditInfo") = getUserAddress & "|" & Request.ServerVariables("REMOTE_USER") ' initialise numerics rsTemp("adjustAmount") = 0 rsTemp("CertificateAmount") = 0 rsTemp("discPerc") = 0 rsTemp("discTotal") = 0 rsTemp("handlingFeeTotal") = 0 rsTemp("otherFeeTotal") = 0 rsTemp("shipmentTotal") = 0 rsTemp("subTotal") = 0 rsTemp("taxTotal") = 0 rsTemp("Total") = 0 'Update Private Comments field if trim(session(storeID & "privateComments")) <> "" then rsTemp("privateComments")= trim(session(storeID & "privateComments")&"") & chr(10) else rsTemp("idAffiliate") = -1 rsTemp("commPerc") = 0 end if 'Update Affiliate fields if isNumeric(session(storeID & "idAffiliate")) _ and isNumeric(session(storeID & "commPerc")) _ and trim(session(storeID & "idAffiliate")) <> "" _ and trim(session(storeID & "commPerc")) <> "" then rsTemp("idAffiliate") = Clng(session(storeID & "idAffiliate")) rsTemp("commPerc") = CDbl(session(storeID & "commPerc")) end if rsTemp.Update 'Put order ID into session object session(storeID & "idOrder") = rsTemp("idOrder") '@@identity idOrder = rsTemp("idOrder") call closeRS(rsTemp) end if 'Check if item is already in the cart and not a certificate idCartRow = 0 if lCase(sku) <> "cert" then mySQL = "SELECT idCartRow,Quantity " _ & "FROM " & tablePrefix & "cartRows " _ & "WHERE idOrder = " & validSQL(idOrder,"I") & " " _ & "AND idProduct = " & validSQL(idProduct,"I") set rsTemp = openRSexecute(mySQL) do while not rstemp.eof 'Get current options and create DB option arrays. mySQL = "SELECT idOption,optionDescrip " _ & "FROM " & tablePrefix & "cartRowsOptions " _ & "WHERE idCartRow = " & rstemp("idCartRow") set rsTemp2 = openRSexecute(mySQL) arrOptionsDB = "" arrOptionsDBTXT = "" do while not rstemp2.eof if len(arrOptionsDB) = 0 then arrOptionsDB = rstemp2("idOption") arrOptionsDBTXT = rstemp2("optionDescrip") else arrOptionsDB = arrOptionsDB & "*,*" & rstemp2("idOption") arrOptionsDBTXT = arrOptionsDBTXT & "*,*" & rstemp2("optionDescrip") end if rstemp2.movenext loop call closeRS(rsTemp2) arrOptionsDB = split(arrOptionsDB,"*,*") arrOptionsDBTXT = split(arrOptionsDBTXT,"*,*") 'Check if Form option arrays and DB option arrays are a match. if UBound(arrOptions) = UBound(arrOptionsDB) then for i = 0 to Ubound(arrOptions) if checkArrayMatch(arrOptions(i),arrOptionsDB) then if len(trim(arrOptionsTXT(i))) > 0 then if not checkArrayMatch(arrOptionsTXT(i),arrOptionsDBTXT) then exit for 'NO MATCH - Text end if end if else exit for 'NO MATCH - ID end if next if UBound(arrOptions) = i-1 then 'MATCHED oldQuantity = rstemp("quantity") IDCartRow = rstemp("idCartRow") exit do end if end if 'Get next Row rsTemp.movenext loop call closeRS(rsTemp) end if 'INSERT new row if idCartRow = 0 then 'Check if item qualifies for discount call getItemDiscount(idProduct,Quantity,unitPrice) 'Make sure the new quantity is at least the minorder amount if cInt(quantity) < cInt(minorder) then errMsg = LangText("ErrMinOrder","Product requires a minimum order of ") & minorder exit sub end if 'INSERT CartRows set rsTemp = openRSopen(tablePrefix & "cartRows",adUseServer,adOpenKeySet,adLockOptimistic,adCmdTable,0) rsTemp.AddNew rsTemp("idOrder") = idOrder rsTemp("idProduct") = IDProduct rsTemp("sku") = SKU rsTemp("quantity") = Quantity rsTemp("unitPrice") = unitPrice rsTemp("unitWeight") = unitWeight rsTemp("description")= Description rsTemp("taxExempt") = taxExempt rsTemp("idDiscProd") = idDiscProd rsTemp("discAmt") = discAmt rsTemp("discExempt") = discExempt rsTemp("handlingfee") = handlingfee rsTemp("dlpassword") = dlpassword rsTemp.Update IDCartRow = rsTemp("idCartRow") 'Return @@identity call closeRS(rsTemp) 'INSERT CartRowsOptions for f = LBound(arrOptions) to UBound(arrOptions) 'If the user entered any text for an option, we assign 'the user's text input to the option description, else 'we assign the option description located in the database. if len(trim(arrOptionsTXT(f))) > 0 then optionDescrip = "'" & left(validSQL(arrOptionsTXT(f),"A"),250) & "'" else optionDescrip = "optionDescrip" end if 'Get Option Price and Percentage mySQL="SELECT priceToAdd, percToAdd " _ & "FROM " & tablePrefix & "options " _ & "WHERE idOption = " & validSQL(arrOptions(f),"I") set rsTemp = openRSexecute(mySQL) if not rsTemp.eof then priceToAdd = getOptionPrice(rsTemp("priceToAdd"),rsTemp("percToAdd"),unitPrice) else priceToAdd = 0 end if call closeRS(rsTemp) 'Update cartRowsOptions mySQL = "INSERT INTO " & tablePrefix & "cartRowsOptions (" _ & "idOrder,idCartRow,idOption,optionPrice," _ & "optionDescrip,optionWeight,taxExempt) " _ & "SELECT " & validSQL(idOrder,"I") & "," _ & validSQL(idCartRow,"I") & "," _ & validSQL(arrOptions(f),"I") & "," _ & validSQL(priceToAdd,"D") & "," _ & optionDescrip & "," _ & "weightToAdd," _ & "taxExempt " _ & "FROM " & tablePrefix & "options " _ & "WHERE idOption = " & validSQL(arrOptions(f),"I") set rsTemp = openRSexecute(mySQL) call closeRS(rsTemp) next 'UPDATE existing row else 'Calculate new quantity newQuantity = oldQuantity + Quantity 'Make sure the new quantity is at least the minorder amount if newQuantity < minorder then errMsg = LangText("ErrMinOrder","Product requires a minimum order of ") & minorder exit sub end if 'Check if item qualifies for discount call getItemDiscount(idProduct,newQuantity,unitPrice) 'Adjust Discount ID for the SQL statement if isNull(idDiscProd) then idDiscProd = "NULL" end if 'Validate quantity again if not quantityValid(newQuantity,stock,idProduct) then connTemp.RollBackTrans exit sub end if 'UPDATE cartRows mySQL = "UPDATE " & tablePrefix & "cartRows " _ & "SET quantity = " & validSQL(newQuantity,"I") & ", " _ & " discAmt = " & validSQL(discAmt,"D") & ", " _ & " discExempt = '" & validSQL(discExempt,"A") & "', " _ & " idDiscProd = " & validSQL(idDiscProd,"I") & " " _ & "WHERE idCartRow = " & validSQL(idCartRow,"I") set rsTemp = openRSexecute(mySQL) call closeRS(rsTemp) end if 'END Transaction connTemp.CommitTrans 'Set CursorLocation of the Connection Object back to Server connTemp.CursorLocation = adUseServer end sub '************************************************************************* ' Remove item from cart '************************************************************************* sub delItem() 'Get cart row to delete IDCartRow = validHTML(Request.QueryString("idCartRow")) 'CartRow was not specified or invalid if len(IDCartRow) = 0 or not isNumeric(IDCartRow) then errMsg = LangText("ErrItemDelete","") exit sub end if 'Set CursorLocation of the Connection Object to Client connTemp.CursorLocation = adUseClient 'BEGIN Transaction connTemp.BeginTrans 'Remove from cartRowsOptions mySQL = "DELETE FROM " & tablePrefix & "cartRowsOptions " _ & "WHERE idCartRow = " & validSQL(idCartRow,"I") & " " _ & "AND idOrder = " & validSQL(idOrder,"I") set rsTemp = openRSexecute(mySQL) call closeRS(rsTemp) 'Remove from cartRows mySQL = "DELETE FROM " & tablePrefix & "cartRows " _ & "WHERE idCartRow = " & validSQL(idCartRow,"I") & " " _ & "AND idOrder = " & validSQL(idOrder,"I") set rsTemp = openRSexecute(mySQL) call closeRS(rsTemp) 'END Transaction connTemp.CommitTrans 'Set CursorLocation of the Connection Object back to Server connTemp.CursorLocation = adUseServer end sub '************************************************************************* ' Update item quantity ' Update item discounts ' Update order discount code '************************************************************************* sub reCalc() dim rsTemp1 'Check if cart has items if cartQty(idOrder) = 0 then errMsg = LangText("ErrCartEmpty","") exit sub end if idAffiliate = Request.form("idAffiliate") if len(idAffiliate) > 0 then if IsNumeric(idAffiliate) then mySQL = "SELECT idCust FROM " & tablePrefix & "customer WHERE idCust = " & validSQL(idAffiliate,"I") set rsTemp = openRSexecute(mySQL) if rsTemp.eof then msg = LangText("genInvalidAffiliateID","Invalid Affiliate ID") else mySQL = "UPDATE " & tablePrefix & "carthead set idAffiliate = " & idAffiliate & " WHERE idOrder = " & validSQL(idorder,"I") set rsTemp = openRSexecute(mySQL) end if else msg = LangText("genInvalidAffiliateFormat","Invalid Affiliate Number") end if end if 'Check if new qty plus existing qty exceeds max for cart for each f in Request.Form if lcase(left(f,4)) = "iqty" and isNumeric(Request.Form(f)) then newQuantity = newQuantity + CLng(Request.Form(f)) end if next if newQuantity > pMaxCartQty then errMsg = LangText("ErrMaxOrdQty","") exit sub end if 'Set CursorLocation of the Connection Object to Client connTemp.CursorLocation = adUseClient 'BEGIN Transaction connTemp.BeginTrans 'Check the cart in order to identify which rows have new quantity mySQL = "SELECT idCartRow,idProduct,quantity,unitPrice " _ & "FROM " & tablePrefix & "cartRows " _ & "WHERE idOrder = " & validSQL(idOrder,"I") set rsTemp = openRSexecute(mySQL) do while not rstemp.eof 'Identify which row to update if Request.Form("iQty" & rstemp("idCartRow")) <> rstemp("quantity") then IDCartRow = rstemp("idCartRow") IDProduct = rstemp("idProduct") newQuantity = Request.Form("iQty" & rstemp("idCartRow")) unitPrice = rsTemp("unitPrice") mySQL = "SELECT minorder FROM " & tablePrefix & "products WHERE idProduct = " & idProduct set rsTemp1 = openRSexecute(mySQL) if IsNull(rsTemp1("minorder")) then minorder = 1 else minorder = rstemp1("minorder") end if if cInt(newQuantity) < minorder then newQuantity = minorder end if 'Validate Quantity if not quantityValid(newQuantity,stock,idProduct) then connTemp.RollBackTrans exit sub end if 'Check if item qualifies for discount call getItemDiscount(idProduct,newQuantity,unitPrice) 'Adjust Discount ID for the SQL statement if isNull(idDiscProd) then idDiscProd = "NULL" end if 'Update cart quantity and discount info mySQL = "UPDATE " & tablePrefix & "cartRows " _ & "SET quantity = " & validSQL(newQuantity,"I") & ", " _ & " discAmt = " & validSQL(discAmt,"D") & ", " _ & " idDiscProd = " & validSQL(idDiscProd,"I") & " " _ & "WHERE idCartRow = " & validSQL(idCartRow,"I") set rsTemp2 = openRSexecute(mySQL) call closeRS(rsTemp2) end if rstemp.movenext loop call closeRS(rsTemp) 'Update the discount code with whatever was entered on the form, 'and reset the discPerc to null or 0. The validity of the 'discount code in relation to this particular order is checked 'later via a common routine that is called every time ANY type 'of update to the order is made. 'Get Discount Code from Form discCode = validHTML(Request.Form("discCode")) 'Update cartHead if len(discCode)=0 or isNull(discCode) then call updateOrderDisc(idOrder,"","") else call updateOrderDisc(idOrder,discCode,0) end if 'END Transaction connTemp.CommitTrans 'Set CursorLocation of the Connection Object back to Server connTemp.CursorLocation = adUseServer end sub '************************************************************************* ' Validate Discount Code ' Update as required '************************************************************************* sub orderDisc() 'Declare variables local to this subroutine dim discDateInt 'Date in internal integer format dim discTotal 'Order discount total amount dim Total 'Retrieve discount code from cart header mySQL = "SELECT discCode " _ & "FROM " & tablePrefix & "cartHead " _ & "WHERE idOrder = " & validSQL(idOrder,"I") set rsTemp = openRSexecute(mySQL) if rsTemp.EOF then errorMsgDisc = LangText("ErrInvOrder","") exit sub else if isNull(rsTemp("discCode")) then discCode = "" else discCode = rsTemp("discCode") end if end if call closeRS(rsTemp) 'Get current date in internal integer format so we can compare 'it to the date range on the order discount file. dim tmpNow tmpNow = currDateTime("DT",timeOffSet) discDateInt = "" _ & year(tmpNow) _ & left("00",2-len(datePart("m",tmpNow))) & datePart("m",tmpNow) _ & left("00",2-len(datePart("d",tmpNow))) & datePart("d",tmpNow) 'See if we have a store wide discount 'Check if discount code is valid, and still active mySQL="SELECT discCode,discPerc,discAmt,discFromAmt,discToAmt " _ & "FROM " & tablePrefix & "discOrder " _ & "WHERE discCode = '" & validSQL("StoreWide","A") & "' " _ & "AND discStatus = 'A' " _ & "AND discValidFrom <= '" & validSQL(discDateInt,"A") & "' " _ & "AND discValidTo >= '" & validSQL(discDateInt,"A") & "' " _ & "ORDER BY idDiscOrder " set rsTemp = openRSexecute(mySQL) if rsTemp.EOF then call closeRS(rsTemp) 'If no discount code is available and no StoreWide discount, update discount info to 'nulls just to be safe, and exit this routine. if discCode = "" then call updateOrderDisc(idOrder,"","") exit sub else 'Check if discount code is valid, and still active mySQL="SELECT discCode,discPerc,discAmt,discFromAmt,discToAmt " _ & "FROM " & tablePrefix & "discOrder " _ & "WHERE discCode = '" & validSQL(discCode,"A") & "' " _ & "AND discStatus = 'A' " _ & "AND discValidFrom <= '" & validSQL(discDateInt,"A") & "' " _ & "AND discValidTo >= '" & validSQL(discDateInt,"A") & "' " _ & "ORDER BY idDiscOrder " set rsTemp = openRSexecute(mySQL) if rsTemp.EOF then errorMsgDisc = LangText("ErrInvDiscCode","") call updateOrderDisc(idOrder,discCode,0) exit sub end if end if end if discPerc = rsTemp("discPerc") discAmt = rsTemp("discAmt") discFromAmt = rsTemp("discFromAmt") discToAmt = rsTemp("discToAmt") discCode = rsTemp("discCode") call closeRS(rsTemp) 'Calculate order total (minus the order discount) Total = cartTotalExDisc(idOrder,0) discBasis = discTotalExempt(idOrder,0) 'Compare order total to order total range on order discount file if Total < discFromAmt or Total > discToAmt then errorMsgDisc = LangText("ErrInvDiscAmt1","") _ & " " & moneyS(discFromAmt) & " - " _ & moneyS(discToAmt) '& LangText("ErrInvDiscAmt2","") call updateOrderDisc(idOrder,discCode,0) exit sub end if 'If the order discount is NOT based on a percentage, but a fixed 'amount, calculate the fixed amount as a percentage of the order. if not isNull(discAmt) then discPerc = (discAmt / Total) * 100 end if 'Just in case the percentages are out of bounds after calculations if discPerc < 0 then discPerc = 0 end if if discPerc > 100 then discPerc = 100 end if 'If we made it this far everything is OK, so we update the cart 'header with the discount percentage for the discount code. Note 'that the order discount total (discTotal) is not updated here, 'but later during the checkout process along with all the other 'totals. call updateOrderDisc(idOrder,discCode,discPerc) end sub '********************************************************************** 'Main Shopping Cart Display Area '********************************************************************** sub cartMain() 'Declare variables local to this subroutine dim discTotal 'Order discount amount dim optTotal 'Total for item's options (per item) dim itemTotal 'Total per item including options and item discounts dim Total 'Total for order dim addCol ' col to add addCol = 0 %>

<%=LangText("GenShoppingCart","")%>

<% if msg <> "" then %>
<%=msg %>
<% end if %> <% if pDisplayCartImage = "-1" then addCol = 1 %> <% else %> <% end if %> <% 'Get discount code and percentage mySQL = "SELECT discCode,discPerc " _ & "FROM " & tablePrefix & "cartHead " _ & "WHERE idOrder = " & validSQL(idOrder,"I") set rsTemp = openRSexecute(mySQL) discCode = rsTemp("discCode") discPerc = rsTemp("discPerc") if isNull(discCode) then discCode = "" end if if isNull(discPerc) then discPerc = 0.00 end if call closeRS(rsTemp) 'Get all rows for this cart mySQL = "SELECT a.idCartRow, a.idProduct, a.sku, a.quantity, a.unitPrice, a.description, a.handlingfee, a.discAmt, b.smallImageUrl, a.idOrder, a.discExempt " _ & "FROM " & tablePrefix & "Cartrows a INNER JOIN " & tablePrefix & "Products b ON a.idProduct = b.idProduct " _ & "WHERE a.idOrder = " & validSQL(idOrder,"I") & " " _ & "ORDER BY a.idCartRow " set rsTemp = openRSexecute(mySQL) do while not rstemp.eof 'Assign record values to local values IDCartRow = rstemp("idCartRow") IDProduct = rstemp("idProduct") Quantity = rstemp("quantity") unitPrice = Exchange(rstemp("unitPrice")) Description = rstemp("description") SKU = rstemp("sku") discAmt = Exchange(rstemp("discAmt")) handlingFee = Exchange(rstemp("handlingfee")) ImageURL = rstemp("smallImageURL") discExempt = rstemp("discExempt") if isNull(discAmt) then discAmt = 0.00 end if if isNull(handlingfee) then handlingfee = 0.00 end if %> <% rstemp.moveNext call saveTotals(total) if not rsTemp.eof then %> <% end if loop call closeRS(rsTemp) %> <% 'If there are active Order Discounts in the database, show Discount 'Code input box and extra total rows. if numOrdDisc() > 0 then %> <% if uCase(UseAffiliateCode) = "Y" then mySQL = "SELECT idAffiliate FROM " & tablePrefix & "carthead WHERE idOrder = " & validSQL(idOrder,"I") set rsTemp = openRSexecute(mySQL) if rsTemp.eof then errMsg = "No order - " & idOrder call closeDB() Response.redirect "sysMsg.asp?errMsg=" & server.URLEncode(errMsg) else idAffiliate = rsTemp("idAffiliate") %> <% end if end if %>
<%=LangText("GenQty","")%> <%=LangText("GenItemDesc","")%><%=LangText("GenItemDesc","")%><%=LangText("GenSubTotal","")%>  
<% if pDisplayCartImage = "-1" then %> /> <% end if %> <%=langProduct(idproduct,"description",description)%> - <%=moneyS(unitPrice)%>
<% 'Write Discount (if any) if discAmt > 0 then Response.Write "* " & LangText("GenDiscount","") & " - " %> <%=moneyS(discAmt)%>
<% end if 'Write Handling Fee (if any) if handlingFee > 0 then Response.Write "* " & LangText("GenHandlingFee","Handling Fee") & " - " %> <%=moneyS(handlingFee)%>
<% end if 'Get all options for this row optTotal = 0 mySQL = "SELECT optionDescrip, optionPrice " _ & "FROM " & tablePrefix & "cartRowsOptions " _ & "WHERE idCartRow = " & validSQL(idCartRow,"I") set rsTemp2 = openRSexecute(mySQL) do while not rstemp2.eof 'Assign record values to local values optionDescrip = rstemp2("optionDescrip") optionPrice = Exchange(rstemp2("optionPrice")) 'Write cartRowOptions line(s) (options) Response.Write "* " & optionDescrip if optionPrice <> 0 then Response.Write " - " %> <%=moneyS(optionPrice)%> <% end if Response.Write "
" 'Calculate options Sub Total optTotal = optTotal + optionPrice rstemp2.movenext loop call closeRS(rsTemp2) itemExempt() %> 		<% 'Display item total itemTotal = Quantity * (optTotal + unitPrice - discAmt + handlingFee) %> <%=moneyS(itemTotal)%>
<% 'Add item total to order total total = total + itemTotal %> 		Delete
<%=LangText("GenDiscCode","")%> : <%=LangText("GenSubTotal","")%> : <%=moneyS(total)%>  
<% 'Show Order Discount details or error if len(trim(errorMsgDisc)) > 0 then Response.Write "" & errorMsgDisc & "  -  " end if if discPerc > 0 then Response.Write "" & formatNumber(discPerc,2) & "% " & LangText("ofAmt","of") & " " Response.Write "" & moneyS(discBasis) & "  -  " end if Response.Write LangText("GenDiscCode","") & " : " %> <% 'Calculate and Show Order Discount Totals discTotal = Round(((discBasis * discPerc) / 100),2) %> <%=moneyS(discTotal)%> <% if discTotal > 0 then Response.Write "  (-)" end if total = total - discTotal end if %>  
<%=LangText("genAffiliateCartHead","Affiliate Credit")%> :
<%=LangText("genEnterAffiliateID","Affiliate ID:") %>

<%=LangText("GenShipping","")%> : Flat Fee $7.00  
<%=LangText("GenTotal","")%> : <%=moneyS(total + "7.00")%>  

<% if freeShipFlag = "-1" then if (freeShipAmt-cartTotal(idOrder,0)) < 0 then 'Response.Write LangText("genFreeShipping","Free Shipping") else 'Response.Write moneyS(Exchange(freeShipAmt-cartTotal(idOrder,0))) & LangText("genFreeShippingLeft"," needed before you qualify for free shipping") end if end if %>

<% 'call saveTotals(Total) %> Save this order, pay later     <% 'Continue Shopping Button idProduct = Request("idProduct") if len(idProduct) > 0 and isNumeric(idProduct) then idCategory = getProdLastCategory(idProduct) errMsg = LangText("genLikeProd","Other products in this category") %> Continue Shopping     <% else if subaction <> "oe" then %> " class="awesome large"> <% else %> <% end if %> Continue Shopping     <% end if %> Checkout

<% if pGoogle = "-1" then call DisplayButton("MEDIUM",true,false) end if %>

<%if pPayPalPro = "-1" then call showExpress() %>

<% 'Show cart message from database mySQL = "SELECT configValLong " _ & "FROM " & adminTablePrefix & "storeAdmin " _ & "WHERE configVar='cartMsg_" & session("language") & "' " _ & "AND adminType='T'" set rsTemp = openRSexecute(mySQL) if not rstemp.eof then %> <%=deletedItems & "

" & trim(rsTemp("configValLong")) & "

"%> <% end if call closeRS(rsTemp) %>
<% if pUseProdCart = "-1" then call getProdRecommendations(idOrder)%>
<% end sub '************************************************************************* 'Scan Array for possible match '************************************************************************* function checkArrayMatch(ByVal tempStr, array1) dim i checkArrayMatch = false tempStr = Lcase(CStr(tempStr)) for i = 0 to Ubound(array1) if LCase(CStr(array1(i))) = tempStr then checkArrayMatch = true exit for end if next end function '************************************************************************* 'Get item's discount ID and amount. 'Assign the ID and amount to variables with page level scope so 'that they can be used outside the function. '************************************************************************* function getItemDiscount(idProduct,itemQty,itemPrice) dim rsTemp 'Initialize External variables idDiscProd = null discAmt = 0.00 'Check Parameters if not isNumeric(idProduct) _ or not isNumeric(itemQty) _ or not isNumeric(itemPrice) then exit function end if 'Check database for possible discount mySQL = "SELECT idDiscProd,discAmt,discPerc " _ & "FROM " & tablePrefix & "DiscProd " _ & "WHERE idProduct = " & validSQL(idProduct,"I") & " " _ & "AND " & validSQL(itemQty,"D") & " >= discFromQty " _ & "AND " & validSQL(itemQty,"D") & " <= discToQty " set rsTemp = openRSexecute(mySQL) if not rsTemp.EOF then idDiscProd = rsTemp("idDiscProd") 'If the product discount is a fixed amount, we simply apply 'the amount, otherwise we calculate the discount based on a 'percentage and move the result to the discount amount field. if isNull(rsTemp("discPerc")) then discAmt = rsTemp("discAmt") else discAmt = Round(((itemPrice * rsTemp("discPerc")) / 100),2) end if end if call closeRS(rsTemp) end function '************************************************************************* 'Update order discount information on cartHead 'Note : Order discount total (discTotal) is updated later along with ' : all the other order totals. '************************************************************************* function updateOrderDisc(idOrder,discCode,discPerc) dim rsTemp 'Check Order ID if len(idOrder) = 0 or not isNumeric(idOrder) then exit function end if 'Check parameters and update accordingly if (len(discCode) = 0 or isNull(discCode)) _ or (len(discPerc) = 0 or not isNumeric(discPerc)) then mySQL = "UPDATE " & tablePrefix & "cartHead " _ & "SET discCode = null, " _ & " discPerc = null, " _ & " discTotal = null " _ & "WHERE idOrder = " & validSQL(idOrder,"I") else mySQL = "UPDATE " & tablePrefix & "cartHead " _ & "SET discCode = '" & validSQL(discCode,"A") & "', " _ & " discPerc = " & validSQL(discPerc,"D") & ", " _ & " discTotal = null " _ & "WHERE idOrder = " & validSQL(idOrder,"I") end if 'Update Order Discount info on cartHead set rsTemp = openRSexecute(mySQL) call closeRS(rsTemp) end function '************************************************************************* 'Validate item quantity '************************************************************************* function quantityValid(quantity,stock,idProduct) dim rsTemp 'Initialize quantityValid = false 'Check for numeric if not IsNumeric(Quantity) then errMsg = LangText("ErrInvQty","") exit function end if 'Check > 0 if CLng(Quantity) <= 0 then errMsg = LangText("ErrInvQty","") exit function end if 'Check max quantity per product if CLng(Quantity) > pMaxItemQty then errMsg = LangText("ErrMaxItemQty","") & pMaxItemQty & "." exit function end if 'Check quantity against available stock if stock level checking 'is enabled. if pHideAddStockLevel <> -1 then if Not OptionInventory(idProduct) then if isNumeric(stock) and not(isEmpty(stock) or isNull(stock)) then if CLng(Quantity) > CLng(Stock) then errMsg = LangText("ErrNoStock","") exit function end if else if isNumeric(idProduct) and not(isEmpty(idProduct) or isNull(idProduct)) then mySQL = "SELECT stock " _ & "FROM " & tablePrefix & "products " _ & "WHERE idProduct = " & validSQL(idProduct,"I") set rsTemp = openRSexecute(mySQL) if CLng(Quantity) > CLng(rsTemp("stock")) then errMsg = LangText("ErrNoStock","") exit function end if call closeRS(rsTemp) end if end if else ' Option Inventory if CLng(Quantity) > CLng(getOptionInventory()) then errMsg = LangText("ErrNoStock","") returnURL = "prodView.asp?idProduct=" & idProduct exit function end if end if end if 'Return quantityValid = true end function '************************************************************************* 'Determine number of available Order Discounts '************************************************************************* function numOrdDisc() dim rsTemp mySQL = "SELECT COUNT(*) AS numOrdDisc " _ & "FROM " & tablePrefix & "discOrder " _ & "WHERE discStatus = 'A' " set rsTemp = openRSexecute(mySQL) numOrdDisc = rsTemp("numOrdDisc") call closeRS(rsTemp) end function '************************************************************************ ' Save the order totals into carthead '************************************************************************ sub saveTotals(Total) dim rsTemp dim mySQL dim currentCurrency dim savedTotal savedTotal = total currentCurrency = request.Cookies("CurrencyCode") if currentCurrency <> currencyDefault then Total = ConvertCurrency(Total,currentCurrency,currencyDefault) mySQL = "UPDATE " & tablePrefix & "carthead " _ & " SET " _ & "subTotal = " & Total & ", " _ & "Total = " & Total & " " _ & "WHERE idOrder = " & validSQL(idOrder,"I") & ";" set rsTemp = openRSexecute(mySQL) total = savedTotal end sub function getOptionInventory() dim optionType dim options dim arrOptions dim mySQL, rsTemp getOptionInventory = 0 if action <> "recalc" then 'Get selected options and place them in arrays for later use for each f in Request.Form if lCase(left(f,11)) = "optidoption" then idOption = mid(f,12) optionType = Request.Form("TYPidoption" & idOption) 'Create an array of selected option ID's if isNumeric(Request.Form(f)) and (optionType = "S" or optionType = "R") then options = options & request.form(f) & "," end if end if next else ' Must be looking at a cartRow in the cart mySQL = "SELECT d.idProduct, a.idOption " _ & "FROM (" & tablePrefix & "CartRowsOptions a INNER JOIN (" & tablePrefix & "OptionsXref b INNER JOIN " & tablePrefix & "OptionsGroups c ON b.idOptionGroup = c.idOptionGroup) ON a.idOption = b.idOption) INNER JOIN " & tablePrefix & "Cartrows d ON a.idCartRow = d.idCartRow " _ & "WHERE c.optionReq = 'Y' AND d.idCartRow = " & validSQL(idCartRow,"I") _ & "GROUP BY d.idProduct, a.idOption ;" set rsTemp = openRSopen(mySQL,adUseServer,adOpenKeySet,adLockOptimistic,adCmdText,0) do while not rsTemp.eof options = options & rsTemp("idOption") & "," rsTemp.movenext loop end if 'Sort the options and get the inventory options = mid(options,1,len(options) -1) arrOptions = split(options,",") arrOptions = sortArray(arrOptions) options = trim(join(arrOptions,",")) mySQL = "Select inventory FROM " & tablePrefix & "optionsinventory " _ & "WHERE idProduct = " & validSQL(idProduct,"I") & " " _ & "AND options = '" & validSQL(options,"A") & "';" set rsTemp = openRSopen(mySQL,adUseServer,adOpenKeySet,adLockOptimistic,adCmdText,0) if not rsTemp.eof then getOptionInventory = rsTemp("inventory") end if closeRS(rsTemp) end function function optionInventory(idProduct) dim mySQL dim rsTemp optionInventory = false mySQL = "SELECT inventory FROM " & tablePrefix & "optionsInventory WHERE idproduct = " & validSQL(idProduct,"I") & ";" set rsTemp = openRSexecute(mySQL) if not rsTemp.eof then optionInventory = true end if end function '***************************************************************************************************** ' Get Shopping Cart Recommendations based upon current order '***************************************************************************************************** sub getProdRecommendations(idOrder) dim smallImageURL mySQL = "SELECT idProduct, description, descriptionLong, imageURL, smallImageURL From " & tablePrefix & "products " _ & "WHERE active = -1 AND idProduct IN " _ & "(SELECT top " & cartViewRecommendationsCount & " od1.idProduct " _ & "FROM (( " & tablePrefix & "cartrows AS od1 " _ & "INNER JOIN " & tablePrefix & "cartrows AS od2 ON od1.idOrder = od2.idOrder) " _ & "INNER JOIN " & tablePrefix & "cartrows AS sp ON od2.idProduct = sp.idProduct) " _ & "WHERE sp.idorder = " & idOrder & " AND od1.idProduct NOT IN " _ & " ( " _ & " SELECT idProduct " _ & " FROM " & tablePrefix & "cartrows " _ & " WHERE idOrder = " & idOrder _ & " ) " _ & " group by od1.idProduct " _ & " order by Count(od1.idProduct) " _ & ")" set rsTemp = openRSexecute(mySQL) if not rsTemp.eof then %>

<%=LangText("genCartRecommendProducts","People that purchased these products also purchased: ") %>

<% do while not rsTemp.eof ' Display the recommended products smallImageURL = rsTemp("smallImageURL") imageURL = rsTemp("imageURL") if len(smallImageURL) = 0 then if len(imageURL) <> 0 then smallImageURL = imageURL end if end if if len(smallImageURL) > 0 then %>
" <%=ImageResize(server.mappath(pImagesDir & smallImageURL),pWThumb,pHThumb,"thumb")%> />

<%=rsTemp("description") %>

<%=rsTemp("DescriptionLong") %>
<% end if rsTemp.movenext loop %> <% end if end sub %>