<% '********************************************************************* ' VP-ASP 6.50 ' July 5, 2005 ' Used by shopkitconfig to add product to the cart '************************************************************************ Dim item Dim Quantity Dim Catalogid Dim ProdCode Dim NameInCart Dim Price Dim ProdCat Dim ProdName, Prodweight Dim basePrice Dim CalcTotal Dim sFtrKeys Dim DollarSign Dim DecimalPlace dim optionalkey dim atemp dim i dim featurenames dim dbc dim selectlistprice dim isselect SetSess "CurrentUrl","shopkitaddtocart.asp" shopinit shopopendatabaseP dbc 'displayfields optionalkey=trim(ucase(getlang("langfeatureoptional"))) DollarSign=GetConfig("xcurrencysymbol") If not HasValue(DollarSign) Then DollarSign = vbNullString DecimalPoint=getconfig("xdecimalpoint") Quantity = 1 CatalogID = Request.Form("hidCatalogID") 'VP-ASP 6.09 - precautionary security fix if not isnumeric(catalogid) then shopclosedatabase dbc shoperror "Catalog ID must be numeric" else catalogid = cint(catalogid) end if 'VP-ASP 6.50 - precautionary security fix ProdCode = cleanchars(Request.Form("hidProdCode")) Price = cleanchars(Request.Form("txtTotal")) ProdCat = CDbl(cleanchars(Request.Form("hidProdCat"))) ProdName = cleanchars(Request.Form("hidProdName")) ProdDesc = cleanchars(REquest.Form("hidProdDesc")) Prodweight = cleanchars(REquest.Form("hidProdweight")) CalcTotal = CDbl(cleanchars(Request.Form("hidProdPrice"))) BasePrice=Calctotal KitGetNameInCart catalogid atemp = split(cleanchars(request.Form("hidfeaturestring")), "<#>") for i = 0 to ubound(atemp)-1 If UCase(request.Form("hid" & replace(atemp(i)," ", "_"))) <> optionalkey and hasValue(request.Form("hid" & replace(atemp(i)," ", "_"))) Then If HasValue(sFtrKeys) then sFtrKeys = sFtrKeys & "," sFtrKeys = sFtrKeys & cleanchars(request.Form("hid" & replace(atemp(i)," ", "_") & "key")) selectlistprice = CDbl(cleanchars(request.Form("hid" & replace(atemp(i)," ", "_")&"price"))) End If next if hasvalue(sFtrKeys) then nameincart=nameincart & FeatureBasePriceFont & getlang("LangproductBasePrice") & shopformatcurrency(Baseprice,getconfig("xdecimalpoint")) & FeatureBasePriceEnd & "
" nameincart=nameincart & FeatureHeaderFont & getlang("LangProductFeaturesOptions") & FeatureHeaderFontEnd GetFeaturenames sFtrkeys, featurenames nameincart=nameincart & featurenames end if AddToCart Catalogid, ProdCode, Quantity, NameInCart, CalcTotal, ProdCat shopclosedatabase dbc responseRedirect "shopaddtocart.asp" '------------------------------------------------------------------------------------------------------------------------ ' Subroutines that may be useful Sub AddToCart (Catalogid, code, quantity, nameincart, price, category) dim scartitem, arrCart dim rc rc=4 'debugwrite " adding " & nameincart 'LocateInArray catalogid,nameincart,rc ' see if we already have some if rc=0 then ' already found exit sub end if arrCart = GetSessA("CartArray") scartItem = GetSess("CartCount") If scartItem = getconfig("xMaxCartitems") and scartItem>0 then shoperror getlang("Langerror02") End If scartitem=scartitem+1 SetSess "CartCount",scartitem arrCart(cProductid,scartItem) = catalogid arrCart(cProductCode,scartItem) = code arrCart(cProductname,scartItem) = NameInCart arrCart(cQuantity,scartItem) = Clng(quantity) arrCart(cOriginalPrice,scartItem) = Price arrCart(cUnitPrice,scartItem) = Price arrCart(cProductFeatures,scartItem) = sFtrKeys if XdualPrice="Yes" then Convertcurrency Price, strDualPrice arrCart(cDualPrice,scartItem) = strDualprice else arrCart(cDualPrice,scartItem) = 0 end if arrCart(cCategory,scartItem) = prodcat arrCart(cDelivery,scartItem) = "" arrCart(cMinimumQuantity,scartItem) = "" arrCart(cmaximumQuantity,scartItem) = "" arrCart(cSupplierid,scartItem) = 0 arrCart(cStockLevel,scartItem) = "" arrCart(cProductimage,scartItem) = "" arrCart(cProductweight,scartItem) = prodweight arrCart(cProductassociated,scartItem) = "" arrCart(cGroupDiscount,scartItem) = "" arrCart(cProductmininame,scartItem) = prodname SetSessA "CartArray",arrCart end sub '------------------------------------------------------------------------------------------------------------------------ ' If we find it then just add new quantity Sub LocateInArray(id,nameincart,rc) Dim i dim lngid dim scartitem dim arrcart lngid=clng(id) rc=4 ' not found scartItem = GetSess("CartCount") If scartitem=0 then exit sub end if arrCart = GetSessA("CartArray") For i = 1 to scartItem If lngid = arrCart(cProductid,i) and nameincart=arrcart(cProductname,i) then arrCart(cQuantity,i) = arrCart(cQuantity,i)+ CInt(quantity) rc=0 SetSessA "CartArray",arrCart exit sub end if Next End Sub '------------------------------------------------------------------------------------------------------------------------ Function HasValue(ByVal sValue) HasValue = false If Not IsNull(sValue) Then sValue = Replace(sValue," ","") If (CStr(sValue) <> vbNullString) And (CStr(sValue) <> "") Then HasValue=True End If End Function '**************************************************************************** ' take all the features and create a string that is added to the cart '**************************************************************************** Sub GetFeaturenames (featureids, sfeature) dim rs, features(100), featurecount, featuresql, featureconn dim strfeaturename, strfeaturecaption,featureprice dim percent, percentamount, featurepercent featurenames="" parserecord featureids, features, featurecount,"," if featurecount=0 then exit sub for i = 0 to featurecount-1 Featuresql = "select * from prodfeatures where id =" & features(i) response.Write features(i) set rs=dbc.execute(featuresql) strfeaturecaption=rs("featurecaption") featureprice=rs("featureprice") if lcase(rs("featuretype")) = "selectlist" then featureprice = selectlistprice featurepercent=rs("featurepercent") if isnull(featureprice) then featureprice=0 If isnull(featurepercent) then featurepercent=0 percentamount=0 If featurepercent<>0 then If featurepercent<1 then featurepercent=featurepercent*100 end if percentamount=(featurepercent/100*calctotal) Percent = featurepercent & "%" percent=percent & " (" & shopformatcurrency(percentamount,getconfig("xdecimalpoint") ) & ")" end if strFeaturename=rs("featurename") sFeature=sfeature & "
" & CartFeatureCaption & strfeaturecaption & CartFeatureCaptionEnd & " " sFeature= sFeature & FeatureFont & strfeaturename & FeatureFontEnd If featureprice <> 0 then CalcTotal = CalcTotal + featurePrice If featureprice>0 then sFeature = SFeature & FeaturePriceFont & getlang("LangFeatureAdd") & shopformatcurrency(featurePrice,getconfig("xdecimalpoint")) & FeaturePriceEnd else sFeature = SFeature & FeaturePriceFont & getlang("LangFeatureSubtract") & shopformatcurrency(featureprice,getconfig("xdecimalpoint")) & FeaturePriceEnd end if end if if percentamount<>0 then calctotal=calctotal+percentamount If percentamount > 0 then sFeature = SFeature & FeaturePriceFont & getlang("LangFeatureAdd") & percent & FeaturePriceEnd else sFeature = SFeature & FeaturePriceFont & getlang("LangFeatureSubtract") & percent & FeaturePriceEnd end if end if closerecordset rs next debugwrite "sfeatures=" & sfeature end sub '********************************************************************* ' get name in card use standard subroutine after opening recordset '********************************************************************* Sub KitGetnameincart (catalogid) dim rsitem, sql sql="select * from products where catalogid=" & catalogid set rsitem=dbc.execute(sql) If not rsitem.eof then memCDescription=rsitem("cdescription") getnameincart rsitem, dbc end if closerecordset rsitem end sub '------------------------------------------------------------------------------------------------------------------------ sub Displayfields dim field for each field in request.form debugwrite field & "=" & request(field) next end sub %>