<% Dim quandbc const quantitypricetable="quantitydiscounts" const maxQuantityFields=5 Sub CalculateUserPrice (Price, quantity, discountPrice, aArray, ArrayIndex) '************************************************************************* ' Quantity based price calculation ' This routine is called by GetProduct to determine whether ' there is a specific price for acustomer ' Handles quantity based discounting ' Version 6.50 ' Nov 24, 2006 HK use prodcategories to determine category '*************************************************************************** dim categoryid, catalogid, salescode, scrtitem if getconfig("xquantityPrices")<>"Yes" then exit sub ' scrtItem = GetSess("CartCount") ShopOpenDatabaseP quandbc catalogid=aArray(cProductid, Arrayindex) categoryid=aArray(cCategory, Arrayindex) if catalogid="" or categoryid="" then HandleGroupDiscount price,discountprice,quantity,rc,scrtitem, aArray, ArrayIndex else LookupQuantityProduct catalogid,categoryid, price,discountprice, quantity, rc if rc>0 then HandleGroupDiscount price,discountprice,quantity,rc,scrtitem, aArray, ArrayIndex end if end if shopclosedatabase quandbc end sub '***************************************** ' Group Sales Discount '******************************************* Sub HandleGroupDiscount (price,discountprice,quantity,rc,scrtitem, aArray, ArrayIndex) dim tdiscountprice If getconfig("xProductGroupDiscount")<>"Yes" then exit sub dim salescode salescode=TRIM(aArray(cGroupDiscount,Arrayindex)) if salescode="" then exit sub dim lookupsql, lookuprs, oldprice, newprice,lngquantity,minquantity,fieldname,maxquantity,pricename,discpercent,discount,dualreprice dim i,k lookupsql="select * from " & quantitypricetable & " where groupfordiscount='" & salescode & "'" Set lookuprs=quandbc.execute(lookupsql) if lookuprs.eof then rc=4 lookuprs.close set lookuprs=nothing exit sub end if '************************************************** 'Getting/Setting Discounts '*************************************************** lngquantity=0 for i=1 to ArrayIndex 'deterimining eligability if aArray(cGroupDiscount,i)=salescode then if i=ArrayIndex then lngquantity=lngquantity+quantity else lngquantity=lngquantity+aArray(cQuantity,i) end if end if next minquantity=lookuprs("minquantity") If lngquantitymaxquantity then exit sub If lngquantity<= maxquantity then pricename="discount" & i discpercent=lookuprs(pricename) exit for end if next If discpercent>=1 then discount=discpercent else discount=Price*discpercent end if 'debugwrite "discountpercent=" & discpercent DiscountPrice=Price-discount DiscountPrice=formatnumber(Discountprice,getconfig("xdecimalpoint")) for i=1 to ArrayIndex if aArray(cGroupDiscount,i)=salescode then oldprice=aArray(cOriginalPrice,i) If discpercent>=1 then Discount=discpercent else discount=OldPrice*discpercent end if TDiscountPrice=oldPrice-discount TDiscountPrice=formatnumber(tDiscountprice,getconfig("xdecimalpoint")) 'debugwrite "Tdiscountprice=" & Tdiscountprice aArray(cUnitPrice,i)=TDiscountPrice if getconfig("XdualPrice")="Yes" then Convertcurrency TdiscountPrice, dualreprice aArray(cDualPrice,i) = dualreprice end if end if next Closerecordset lookuprs End Sub '*********************************************************** 'See if we can find it by catalogid '************************************************************ Sub LookupQuantityProduct (catalogid, categoryid, Price,discountprice, quantity, rc) dim lookupsql, lookuprs, oldprice, newprice Dim Discountamount,DiscountPercent ' The current version usess single category or product lookupsql="select * from " & quantitypricetable lookupsql = lookupsql & " where catalogid=" & catalogid lookupsql = lookupsql & " or categoryid=" & categoryid Set lookuprs=quandbc.execute(lookupsql) if lookuprs.eof then rc=4 lookuprs.close set lookuprs=nothing QuantityMatchsubcategories quandbc, catalogid, rc, lookuprs If rc=0 then GetQuantityDiscount lookuprs, price, discountprice, quantity lookuprs.close set lookuprs=nothing rc=0 exit sub else rc=4 exit sub end if end if GetQuantityDiscount lookuprs, price, discountprice, quantity lookuprs.close set lookuprs=nothing rc=0 end sub '************************************************************** ' we have a record now apply the discount '************************************************************** Sub GetQuantityDiscount (rs, price, discountprice, quantity) dim discpercent, fieldname, pricename, maxquantity, minquantity, i dim lngquantity, discount lngquantity=clng(quantity) minquantity=rs("Minquantity") If lngquantity=1 then discount=discpercent else discount=Price*discpercent end if 'debugwrite "discountpercent=" & discpercent DiscountPrice=Price-discount DiscountPrice=formatnumber(Discountprice,getconfig("xdecimalpoint")) exit for end if next 'debugwrite "Discountprice=" & discountprice end sub Sub QuantityMatchsubcategories (quandbc, catalogid, rc, lookuprs) dim sql, rs, categories if catalogid="" then rc=4 exit sub end if sql="SELECT * from prodcategories where intcatalogid=" & catalogid set rs=quandbc.execute(sql) do while not rs.eof If categories<>"" then categories=categories & "," end if categories=categories & rs("intcategoryid") rs.movenext loop closerecordset rs sql="select * from quantitydiscounts where categoryid in (" & categories & ")" sql = sql & " order by categoryid" set lookuprs=quandbc.execute(sql) if lookuprs.eof then rc=4 closerecordset lookuprs exit sub end if rc=0 end sub %>