<% '************************************************************************* ' Version 6.50 VP-ASP ' Customer based pricing ' after a price has been read from the database ' This routine is called by GetProduct to determine whether ' there is a specific price for acustomer ' Nov 9, 2006 HK allow customer price groups percentages ' using new configuration option xcustomerpricepercents '*************************************************************************** dim custdbc const customerpricetable="customerprices" Sub ShopCustomerPrices (objrs, catalogid, categoryid, ioprice, newprice,discount) '**************************************************************** ' obtain the correct price for the customer ' first lookup specific product ' if not found lookup specific category '***************************************************************** dim customerid, rc if getconfig("xcustomerPrices")<>"Yes" then exit sub if getconfig("Xcustomerpricefields")<>"" or getconfig("Xcustomerpricepercents")<>"" then CustomerPricesinRecord objrs, catalogid, categoryid, ioprice, newprice,discount exit sub end if discount=0 newprice=ioprice customerid=GetSess("Customerid") if customerid="" then exit sub end if ShopOpenDatabase custdbc LookupCustomerProduct catalogid, customerid, newprice,discount, rc if rc= 0 then exit sub end if LookupCustomerCategory categoryid, customerid, NewPrice,discount, rc if rc=0 then exit sub end if LookupCustomerOnly customerid, NewPrice,discount, rc if rc=0 then exit sub end if shopclosedatabase custdbc end sub ' Sub LookupCustomerProduct (catalogid, customerid, Price,discount, rc) dim lookupsql, lookuprs, oldprice, newprice Dim Discountamount,DiscountPercent lookupsql="select * from " & customerpricetable lookupsql = lookupsql & " where customerid=" & customerid lookupsql = lookupsql & " and catalogid=" & catalogid Set lookuprs=custdbc.execute(lookupsql) if lookuprs.eof then rc=4 lookuprs.close set lookuprs=nothing exit sub end if discountamount=lookuprs("discountamount") discountpercent=lookuprs("discountpercent") ApplyCustomerPrice Price, discountamount, discountPercent, discount lookuprs.close set lookuprs=nothing shopclosedatabase custdbc end sub Sub ApplyCustomerprice (price, amount, percent, discount) dim newprice If not isnull(amount) and amount>0 then Newprice=price-amount discount=newprice/price discount=1-discount discount=discount*100 price=newprice exit sub end if If not isnull(percent) then discount=percent if percent>1 then percent=percent/100 end if Newprice=price- (Price*percent) NewPrice=formatnumber(NewPrice,getconfig("xdecimalpoint")) price=Newprice end if 'debugwrite "newprice=" & newprice end sub Sub LookupCustomerCategory (categoryid, customerid, Price,discount, rc) Dim Discountamount,DiscountPercent dim lookupsql, lookuprs, discountper, newprice lookupsql="select * from " & customerpricetable lookupsql = lookupsql & " where customerid=" & customerid lookupsql = lookupsql & " and categoryid=" & categoryid set lookuprs=custdbc.execute(lookupsql) if lookuprs.eof then rc=4 lookuprs.close set lookuprs=nothing exit sub end if Discountamount=lookuprs("Discountamount") DiscountPercent=lookuprs("Discountpercent") if getconfig("xdebug")="Yes" then debugwrite "Price=" & price & " discountPercent=" & discountpercent end if ApplycustomerPrice Price, discountamount, discountPercent, discount lookuprs.close set lookuprs=nothing shopclosedatabase custdbc rc=0 end sub Sub LookupCustomerOnly (customerid, Price,discount, rc) Dim Discountamount,DiscountPercent dim lookupsql, lookuprs, discountper, newprice lookupsql="select * from " & customerpricetable lookupsql = lookupsql & " where customerid=" & customerid lookupsql = lookupsql & " and categoryid=0 and catalogid=0" Set lookuprs=custdbc.execute(lookupsql) if lookuprs.eof then rc=4 lookuprs.close set lookuprs=nothing exit sub end if Discountamount=lookuprs("Discountamount") DiscountPercent=lookuprs("Discountpercent") if getconfig("xdebug")="Yes" then debugwrite "Price=" & price & " discountPercent=" & discountpercent end if ApplycustomerPrice Price, discountamount, discountPercent, discount lookuprs.close set lookuprs=nothing shopclosedatabase custdbc rc=0 end sub '**************************************************************** ' contact id field determines which customer price field to use ' objrs is the current record in products table ' Uses xcustomerpricefields ' xcustomepricesindexes '***************************************************************** sub CustomerPricesinRecord (objrs, catalogid, categoryid, ioprice, newprice,discount) dim fields(50),fieldcount, customerpricefields, customerpricetypes dim types(50), typecount, customertype, ctype, pricefield dim donumerictest, i, xdebug dim customerpricepercents ' specific discount percentage per group dim usediscountgroup on error goto 0 xdebug=getconfig("xdebug") usediscountgroup=false if getsess("customertype")="" then exit sub customerpricefields=getconfig("Xcustomerpricefields") customerpricetypes=getconfig("Xcustomerpricetypes") customerpricepercents=getconfig("Xcustomerpricepercents") customertype=getsess("customertype") If isnumeric(customertype) then customertype=clng(customertype) donumerictest=true else donumerictest=false customertype=ucase(customertype) end if If xdebug="Yes" then debugwrite "Pricefields=" & customerpricefields debugwrite "Types=" & customerpricetypes debugwrite "Customer type=" & getsess("customertype") end if if customerpricetypes="" then exit sub ' If there are no customer price fields then see if there are ' group discounts and use them if customerpricefields="" then if customerpricepercents<>"" then usediscountgroup=true else exit sub end if end if parserecord customerpricefields, fields,fieldcount,"," parserecord customerpricetypes, types,typecount,"," for i = 0 to typecount-1 ctype=types(i) if donumerictest=true then if isnumeric(ctype) then ctype=clng(ctype) 'debugwrite "comparing2 ctype=" & ctype & " against " & customertype if customertype=ctype then pricefield=fields(i) If usediscountgroup=false then SetCustomerPricefield objrs, pricefield, newprice, i else SetCustomerDiscountGroup newprice, i end if exit sub else ' debugwrite "did not match " & ctype & " ct=" & customertype end if end if else ' debugwrite "comparing2 ctype=" & ctype & " against " & customertype if customertype=ucase(ctype) then If usediscountgroup=false then pricefield=fields(i) SetCustomerPricefield objrs, pricefield, newprice, i else SetCustomerDiscountGroup newprice, i end if exit sub end if end if next end sub Sub SetCustomerpricefield (objrs, fieldname, price, i) dim tprice tprice=objrs(fieldname) if isnull(tprice) then SetCustomerDiscountGroup price, i exit sub end if price=tprice end sub '************************************************************************** ' Using xcustomerpricepercents ' to apply a discount ' could be used when no customerprice fields are if price field is null ' If percent is greater tahn 1, customer prive can be greater than original price '************************************************************************* sub SetCustomerDiscountGroup (newprice, i) dim customerpricepercents, percents(50), percentcount dim percent dim oldprice dim discount customerpricepercents=getconfig("Xcustomerpricepercents") if customerpricepercents="" then exit sub parserecord customerpricepercents, percents, percentcount,"," percent=percents(i) ' get actual persent if percent="" then exit sub ' no discount if not isnumeric(percent) then exit sub ' not numeric oldprice=newprice If percent<1 then discount=oldprice*csng(percent) newprice=oldprice-discount else newprice=newprice*percent end if 'debugwrite "discount oldprice=" & oldprice & " percent=" & percent & " newprice=" & newprice end sub %>