<% '************************************************************ ' Version 5.0 ' This routine displays the shopping cart and does recalculation ' if returnurl is passed, this routine returns back to that URL ' Feb 25, 2004 fix dynamic return with firewall '******************************************************* Dim prodid, quantity, arrCart, scartItem Dim strAction, pi, dualreprice Dim returnurl dim ContinueURL ContinueURL=getconfig("xcontinueshopping") If getconfig("xcontinueshoppingdynamic")="Yes" then Setcontinueurl continueurl end if '****************************** ' This form can call itself. ' We need to know if it is a new product add or just a recalculation ' Inputs are productid, quantity ' '******************************* sError="" strAction=Request("Continue") If straction="" then strAction=Request("Continue.x") end if if straction<>"" then strAction="CONTI" else strAction=Request("Checkout") If straction="" then straction=Request("Checkout.x") end if if straction<> "" then strAction="PROCE" else strAction=request("Recalculate") if straction="" then straction=Request("REcalculate.x") end if if strAction<>"" then strACTION="RECAL" end if end if end if if strAction<>"" then ReprocessForm else ProcessNewadd end if ' new item is to be added to cart Sub ProcessNewAdd() Dim rc ShopInit GetInputValues arrCart = GetSessA("CartArray") scartItem = GetSess("CartCount") if scartitem="" then responseredirect "shopemptycart.asp" end if If scartItem = 0 and prodid="" Then responseredirect "shoperror.asp?msg=" & Server.URLEncode (getlang("langError01")) End If If prodid <> "" Then If scartItem = getconfig("xMaxCartitems") and scartItem>0 then responseredirect "shoperror.asp?msg=" & Server.URLEncode (getlang("langerror02")) End If CartAddItem prodid, rc if rc > 0 then sError=getlang("langErrorNoProduct") & "id=" & prodid end if returnurl=request("returnurl") if returnurl<>"" then responseredirect returnurl end if end if DisplayForm end sub Sub GetInputValues ' Keys are ' productid = a number in the database ' quantity = a number of items ' db = database to change the database ' Dim sOption, sUserText, sUserTextvalue Dim optionnum Dim maxFeatures dim sMultiOption, sMultiValue Dim i prodid = Request("productid") if prodid="" then prodid=request("catalogid") end if quantity = Request("quantity") If Quantity<>"" then ValidateQuantity quantity end if If prodid<>"" and quantity="" then quantity=1 end if ' There can be up to 4 different features for a product option1, option2 maxfeatures=getconfig("xMaxFeatures") SetSess "Maxfeatures",maxfeatures prodi="" If prodid<>"" then CartGetProduct prodid, rc If rc=0 then SetSess "newProductPrice","" GetProductFeatures prodi ' in shopproductfeatures.asp else sError=serror & getlang("langErrorNoProduct") & "id=" & prodid & "
" shoperror serror end if end if end sub ' Sub ReprocessForm dim cartattributes, maxcartitems arrCart = GetSessA("CartArray") scartItem = GetSess("CartCount") Select Case strAction Case "CONTI" responseredirect ContinueURL Case "RECAL" ' Response.write "recalculating" dim Newcart Dim Newcount Dim tquantity Dim confirm dim testremove Dim x dim msg, stocklevel cartattributes=cMaxCartAttributes maxcartitems=getconfig("xmaxcartitems") newcount=0 ReDim newcart(cartAttributes,maxCartItems) For i = 1 to scartItem confirm = Request.Form("selected" & CStr(i)) tquantity = Request.Form("Quantity" & Cstr(i)) if Not isnumeric(tquantity) then tquantity=1 end if validatequantity tquantity Correctminimumquantity tquantity, arrCart(cMinimumquantity,i) Correctmaximumquantity tquantity, arrCart(cMaximumquantity,i) stocklevel=arrCart(cStocklevel,i) If getconfig("XcheckStocklevel")="Yes" Then If stocklevel<>"" then CheckStockLevelRecalculate stocklevel,tquantity, arrcart, scartitem, i, msg end if end if arrCart(cQuantity,i)=tquantity if getconfig("xcartremoveChecked")="Yes" Then testremove="yes" else testremove="" end if If confirm <> testremove or tquantity=0 Then else newcount=newcount+1 cartattributes=cMaxCartAttributes for x = 1 to cartAttributes NewCart(x, newcount) = arrCart(x,i) next ProductPrice=Newcart(cOriginalPrice,newcount) NewCart(cUnitPrice,newcount)=ProductPrice DiscountPrice=ProductPrice CalculateUserPrice ProductPrice, tquantity, DiscountPrice, Newcart, Newcount Newcart(cUnitPrice,newcount)=DiscountPrice Convertcurrency discountPrice, dualreprice Newcart(cDualPrice,newcount) = dualreprice end if Next SetSess "CartCount", newcount SetSessA "CartArray", Newcart arrcart=Newcart scartitem=newcount Serror=msg Case "PROCE" responseredirect "shopcustomer.asp" End Select DisplayForm End Sub ' Sub display form Sub DisplayForm() ShopPageHeader If Serror<>"" then shopwriteerror serror end if arrCart = GetSessA("CartArray") scartItem = GetSess("CartCount") FormatFormFields ShopPageTrailer end sub ' Format form Sub FormatFormFields %> <%=CartHeaderFont%><%=getlang("langCart01")%> <%=scartitem%><%=CartHeaderEnd%>

<% dim allowdelete allowdelete="TRUE" CartFormat allowdelete response.write "
" If Getconfig("xbuttoncontinueshopping")="" Then %> "> <% else %>"> <% end if If Getconfig("xbuttonrecalculate")="" Then %> "> <% else %>"> <% end if If Getconfig("xbuttoncheckout")="" Then %> "> <% else %>"> <% end if %>

<%=CartInfoFont%><%=getlang("langCart02")%><%=CartInfoFontEnd%> <% if getconfig("xAllowSaveCart")="Yes" Then Response.write "
" & "" & getlang("langSaveCart") & "" & "
" End if if getconfig("xWishlist")="Yes" Then Response.write "
" & "" & getlang("langwishlist") & "" & "
" End if End Sub Sub CheckStockLevelRecalculate (stocklevel,tquantity, arrcart, scartitem, index, msg) Dim i dim lstock dim totquantity dim lngid, newlevel lngid = arrCart(cProductid,index) lstock=clng(stocklevel) totquantity=clng(tquantity) For i = 1 to scartItem If lngid = arrCart(cProductid,i) then If i<>index then Totquantity=arrCart(cQuantity,i) +totquantity end if end if Next If totquantity>lstock then newlevel=lstock-totquantity If newlevel>=1 then tquantity=newlevel else tquantity=arrCart(cQuantity,index) end if Msg=Msg & getlang("langStockChanged") & "
" & arrCart(cProductname,index) &"
" end if end sub '********************************************************************* ' Find out where we came from '********************************************************************* Sub SetContinueurl (continueurl) dim pagefrom, words(20),wordcount pagefrom= request.servervariables("http_referer") parserecord pagefrom, words, wordcount,"/" if lcase(words(wordcount-1))<>"shopaddtocart.asp" then setsess "pagefrom",pagefrom else pagefrom=getsess("pagefrom") if pagefrom="" then pagefrom=getconfig("xcontinueurl") end if end if continueurl=pagefrom if continueurl="" then continueurl=getconfig("xcontinueurl") end if If getconfig("xdebug")="Yes" then debugwrite "will return to " & continueurl end if end sub %>