<%
'***************************************************
' Version 6.50
' This routine is used to obtain features and display them
' Analyze features customer has selected
' add a product to the internal shopping Cart
' This routine consist of three separate parts
' CartAddItem used to add aproduct to the shopping cart
' FormatProductOptions Generates the form fields for product features
' GetProductFeatures Process the user selected features
' Sept 7,2004 add spacing for non English features
' Sept 11, 2004 add cloning of products
' Sept 22, 2004 Fix quantity discounts
' Dec 12, 2004 fix clone products
' July 5, 2005 Inventory Products
'*************************************************
'
dim prodindex
dim FeatureMultiSelection
dim Sfeature
Dim NameInCart
Dim fcount
Dim sSelect
Dim PrevOptionNum
Dim tempOption
dim maxOptionNum
dim strDualPrice
Dim ProductPrice
Dim DiscountPrice
Dim OriginalPrice
Dim userselectedstring
dim fprefix
Dim sxRequiredList, sXRequiredValue
dim lngFeatureid
dim featurevaluecount
Dim ProductSku, Featureconn
Dim requiredlist
dim userselectedcount, userselected(100)
dim featurequantity, strfeaturedefault
'***************************************************
' add a product to the cart. Common routine
' handles feature analysis and discounts'
'*****************************************************
Sub CartAddItem(id, rc)
' Return 0 if added, 4 if product does not exist
' Get from datbase and add to instorage array
'Debugwrite "cartadditem =" & id
dim scartitem
Dim arrCart
Dim TotalOptionPrice
dim TotaloptionDualPrice
Dim Optionname
Dim CartFields, ArtFieldcount
ProductPrice=CurCPrice ' original price
featurequantity=""
If GetSess ("NewProductPrice")<>"" then
ProductPrice=GetSess("NewProductPrice") ' created by features
If GetSess ("NewProductQuantity")<>"" then
quantity=GetSess("NewProductquantity") ' created by features
end if
end if
DiscountPrice=ProductPrice ' DiscountPrice
OriginalPrice=ProductPrice
LocateInArray id,rc ' see if we already have some
if rc=0 then ' already found
exit sub
end if
' old method, now uses cartfields in shop$colors
' NameinCart=strcName & " " & memCDescription ' description
arrCart = GetSessA("CartArray")
scartItem = GetSess("CartCount")
scartitem=scartitem+1
If scartItem > clng(getconfig("xMaxCartitems") )then
shoperror getlang("Langerror02")
End If
arrCart(cProductid,scartItem) = lngcatalogID
arrCart(cCategory,scartItem) = lngCcategory
arrCart(cProductCode,scartItem) = strccode
arrCart(cGroupDiscount,scartItem) = strgroupfordiscount
AddCartOptions TotalOptionPrice, TotalOptionDualPrice
'Added option price to product price for use with calculating userprice
productprice=productprice+totaloptionprice
originalprice=originalprice+totaloptionprice
discountprice=discountprice+totaloptionprice
If featurequantity<>"" then
quantity=featurequantity
end if
CorrectMinimumquantity quantity,strminimumquantity
Correctmaximumquantity quantity,strmaximumquantity
CheckStockLevel quantity, lngcatalogid
CalculateUserPrice ProductPrice, Quantity, DiscountPrice, arrCart, scartitem
ProductPrice=DiscountPrice
AddUserText ' text within product record
If not IsNull(StrSpecialOffer) then
NameIncart = NameInCart & " " & strSpecialOffer
end if
arrCart(cProductname,scartItem) = NameInCart
arrCart(cQuantity,scartItem) = quantity
'removed total option price as it now has been added earlier
' arrCart(cOriginalPrice,scartItem) = OriginalPrice + TotalOptionPrice
' arrCart(cUnitPrice,scartItem) = ProductPrice + TotaloptionPrice
arrCart(cOriginalPrice,scartItem) = OriginalPrice
arrCart(cUnitPrice,scartItem) = ProductPrice
arrCart(cProductFeatures,scartItem) = UserSelectedString
if getconfig("XdualPrice")="Yes" then
If strcdualprice="" then
Convertcurrency ProductPrice, strDualPrice
else
strdualprice=strcdualprice ' get from product
end if
ConvertCurrency TotaloptionPrice, TotalOptionDualPrice
'There is now no need to add the totaloptiondualprice to the dualprice as features have already been added to the product price earlier
'arrCart(cDualPrice,scartItem) = strDualprice + TotaloptionDualPrice
arrCart(cDualPrice,scartItem) = strDualprice
else
arrCart(cDualPrice,scartItem) = 0
end if
arrCart(cMinimumQuantity,scartItem) = strminimumquantity
arrCart(cSupplierid,scartItem) = strsupplierid
arrCart(cDelivery,scartItem) = ""
'VP-ASP 6.50 - allow customers to upload images
arrCart(cuploadimagerequired,scartItem) = strCustomerImage
arrCart(cgraphicname1,scartItem) = ""
if isnull(lngcstock) then
lngcstock=""
end if
If GetSess ("NewProductPrice")="" then
arrCart(cmaximumQuantity,scartItem) = strmaximumquantity
else
If GetSess ("NewProductQuantity")<>"" then
quantity=GetSess("NewProductquantity") ' created by features
AdjustQuantityPrices arrcart, scartitem, quantity, productprice, totaloptionprice
setsess "NewProductquantity",""
end if
end if
arrCart(cStockLevel,scartItem) = lngcstock
arrCart(cProductimage,scartItem) = strcimageurl
arrCart(cProductweight,scartItem) = strweight
arrCart(cProductassociated,scartItem) = ""
arrCart(cProductmininame,scartItem) = strcname
If quantityproducts<>"" Then
Cloneproducts arrcart, scartitem
end if
SetSess "CartCount",scartitem
SetSessA "CartArray",arrCart
rc=0
end sub
'
' If we find it then just add new quantity
Sub LocateInArray(id,rc)
Dim i
dim lngid
dim scartitem
dim arrcart
lngid=clng(id)
rc=4 ' not found
' Anything with features needs to be added new
If strFeatures<>"" then
CheckFeaturesStockLevel quantity, lngcatalogid
exit sub
end if
If memUserText<>"" then
exit sub
end if
scartItem = GetSess("CartCount")
If scartitem=0 then
exit sub
end if
arrCart = GetSessA("CartArray")
dim newquantity
For i = 1 to scartItem
If lngid = arrCart(cProductid,i) then
newquantity=arrCart(cQuantity,i)+clng(quantity)
validatequantity newquantity
'VP-ASP 6.08 - display a message when maximum quantity is reached
CorrectMinimumquantity newquantity,strminimumquantity
Correctmaximumquantity newquantity,strmaximumquantity
CheckStockLevel newquantity, lngcatalogid
arrCart(cQuantity,i) = newquantity
CalculateUserPrice arrCart(cOriginalPrice,i), arrCart(cQuantity,i), DiscountPrice, arrcart, i
arrCart(cUnitPrice,i)=DiscountPrice
rc=0
SetSessA "CartArray",arrCart
exit sub
end if
Next
End Sub
Sub GenerateMinQuantityList (i, quantity)
dim lngquantity
Dim PArray(100),PArrayCount
dim amount, sSelect, j
lngquantity=clng(quantity)
' Fix Oct 19
parraycount=getconfig("xproductminimumlist")
if parraycount="" then
parraycount=6
end if
parraycount=clng(parraycount)
for j = 1 to parraycount
amount=j*minamount
parray(j)=amount
next
sSelect = sSelect & ""
%>
<%=sSelect%>
<%
end sub
'
Sub CheckStockLevel (quantity, catalogid)
dim lstock, totquantity, i, lngid, scartitem, arrcart
If getconfig("XCheckStockLevel")<>"Yes" then exit sub
if isnull(lngcstock) then exit sub
lstock=clng(lngcstock)
lngid=clng(catalogid)
totquantity=clng(quantity)
scartItem = GetSess("CartCount")
'VP-ASP 6.09 - check if amount to order exceeds stock
If totquantity>lstock then
shoperror getlang("LangStockLevel") & "(" & lngcstock & ") - " & strcname
end if
If scartitem=0 then
exit sub
end if
'VP-ASP 6.09 - Commented out following - eg. if there were only two items in stock and the
'customer added one, then went back and added it again, it wasn't allowing them to do this.
'arrCart = GetSessA("CartArray")
'For i = 1 to scartItem
' If lngid = arrCart(cProductid,i) then
' Totquantity=arrCart(cQuantity,i) +totquantity
' end if
'Next
'If totquantity>lstock then
' shoperror getlang("LangStockLevel") & "(" & lngcstock & ") - " & strcname
'end if
end sub
Sub AddCartOptions (totalOptionPrice, TotalOptionDualPrice)
'**********************************************************************
' Features have been stored in the feature array
' feature count has the number of features stored
'**********************************************************************
Dim sPrice
Dim OPrice
Dim optionName
Dim sFeature, featureother
Dim MaxFeatures, msg, tempselect
TotalOptionPrice=0
TotaloptionDualPrice=0
sFeature=""
Productsku=""
sPrice=""
Maxfeatures=Featurecount
If maxfeatures=0 then exit sub
'Debugwrite "featurecount=" & featurecount
sFeature=""
dim percent, percentamount
for i = 0 to MaxFeatures-1
strfeaturename= Featurearray(cfeaturevalue,i)
oprice=Featurearray(cfeatureprice,i)
featureother=Featurearray(cfeatureother,i)
strfeaturecaption=Featurearray(cfeaturecaption,i)
strfeaturepercent=Featurearray(cfeaturepercent,i)
percentamount=0
If strfeaturepercent<>"" then
If strfeaturepercent<1 then
strfeaturepercent=strfeaturepercent*100
end if
percentamount=(strfeaturepercent/100*curcprice)
Percent = strfeaturepercent & "%"
end if
if sFeature="" Then
If curcprice>0 then
sFeature= FeatureBasePriceFont & getlang("LangproductBasePrice") & shopformatcurrency(curCPrice,getconfig("xdecimalpoint")) & FeatureBasePriceEnd
sFeature= sFeature & " " & FeatureHeaderFont & getlang("LangProductFeaturesOptions") & FeatureHeaderFontEnd
end if
end if
sFeature=sfeature & " " & CartFeatureCaption & strfeaturecaption & CartFeatureCaptionEnd & " "
sFeature= sFeature & FeatureFont & strfeaturename & FeatureFontEnd
if getconfig("xcurrencysymbol")<>"" and oprice<>"" then
oprice=replace(oprice,getconfig("xcurrencysymbol"),"")
end if
If oprice="" then
oprice=0
end if
if OPrice<>0 then
TotalOptionPrice=TotaloptionPrice+OPrice
If Oprice > 0 then
sFeature = SFeature & FeaturePriceFont & " " & getlang("LangFeatureAdd") & shopformatcurrency(OPrice,getconfig("xdecimalpoint")) & FeaturePriceEnd
else
sFeature = SFeature & FeaturePriceFont & " " & getlang("LangFeatureSubtract") & shopformatcurrency(OPrice,getconfig("xdecimalpoint")) & FeaturePriceEnd
end if
end if
if percentamount<>0 then
TotalOptionPrice=TotaloptionPrice+percentamount
If percentamount > 0 then
sFeature = SFeature & FeaturePriceFont & " " & getlang("LangFeatureAdd") & percent & FeaturePriceEnd
else
sFeature = SFeature & FeaturePriceFont & " " & getlang("LangFeatureSubtract") & percent & FeaturePriceEnd
end if
end if
Createsku productsku, featureother
next
NameInCart=NameIncart & sFeature
If Productsku<>"" and getconfig("xgeneratesku")="Yes" then
NameinCart= "Sku: " & Productsku & " " & NameinCart
end if
end sub
'
'
'
Sub CreateSku (productsku, strfeatureother)
If isnull(strfeatureOther) then exit sub
If strfeatureother="" then exit sub
If ProductSku="" then
Productsku=strccode
end if
Productsku=Productsku & "-" & strfeatureother
end sub
'
'
Sub VerifyRequired (msg)
dim requiredlist
msg=""
' SxRequirelistvalue ha the list of features that are required
Requiredlist=split(sxrequiredvalue,",")
For i = 0 to ubound(Requiredlist)
FindSelected RequiredList(i), msg
next
end sub
'
Sub FindSelected (feature, msg)
' Find this required feature in the list of selected features
dim j, tempmsg, fsql, featurecaption, rs
'debugwrite "selectedcount=" & userselectedcount
If featurecount>0 then
for j =0 to featurecount
' Debugwrite "feature=" & feature & "selected=" & Userselected(j)
if clng(feature)=clng(Featurearray(cfeaturenum,j)) then
exit sub
end if
next
end if
Fsql="select * from prodfeatures where featurenum=" & feature
set rs=Featureconn.execute(fsql)
'VP-ASP 6.50 - verify that something is in recordset
if not rs.eof then
featurecaption=rs("featurecaption")
else
featurecaption = ""
end if
rs.close
set rs=nothing
tempmsg= getlang("LangFeatureMissing") & strcname & " - " & featurecaption & " "
msg=msg & tempmsg
end sub
'
Sub CheckFeaturesStockLevel (quantity, catalogid)
dim lstock
dim totquantity
Dim i
dim lngid
dim scartitem
dim arrcart
If getconfig("XCheckStockLevel")<>"Yes" then exit sub
if isnull(lngcstock) then exit sub
lstock=clng(lngcstock)
lngid=clng(catalogid)
totquantity=clng(quantity)
scartItem = GetSess("CartCount")
If scartitem=0 then
exit sub
end if
'VP-ASP 6.09 - Commented out following - eg. if there were only two items in stock and the
'customer added one, then went back and added it again, it wasn't allowing them to do this.
'arrCart = GetSessA("CartArray")
'For i = 1 to scartItem
' If lngid = arrCart(cProductid,i) then
' Totquantity=arrCart(cQuantity,i) +totquantity
' end if
'Next
'If totquantity>lstock then
' shoperror getlang("LangStockLevel") & "(" & lngcstock & ") - " & strcname
'end if
end sub
'
'*********************************************************
' make sure quantity matches minimum
'********************************************************
Sub CorrectminimumQuantity (quantity, minquantity)
dim tempmin
if getconfig("xproductminimumquantity")<>"Yes" then exit sub
if not isnumeric (minquantity) then exit sub
tempmin=clng(minquantity)
if tempmin= 0 then exit sub
if clng(quantity)>= tempmin then exit sub
quantity=tempmin
end sub
'
'*********************************************************
' make sure quantity matches minimum
'********************************************************
Sub CorrectMaximumQuantity (quantity, maxquantity)
dim tempmin
if getconfig("xproductmaximumquantity")<>"Yes" then exit sub
if not isnumeric (maxquantity) then exit sub
tempmin=clng(maxquantity)
if tempmin= 0 then exit sub
if clng(quantity)<= tempmin then exit sub
quantity=tempmin
'VP-ASP 6.08 - display a message when maximum quantity is reached
dim theerrmessage
theerrmessage= "You can only order " & maxquantity & " of this item."
serror=theerrmessage
end sub
Sub AdjustQuantityPrices (arrcart, scartitem, quantity, productprice, totaloptionprice)
dim price
arrCart(cmaximumQuantity,scartItem) = quantity
arrCart(cQuantity,scartItem) = quantity
Price=GetSess("NewProductPrice")
price=price/quantity
arrCart(cOriginalPrice,scartItem) = price
arrCart(cUnitPrice,scartItem) = price
price=arrCart(cDualPrice,scartItem)
price=price/quantity
arrCart(cDualPrice,scartItem)=price
setsess "NewProductQuantity",""
arrCart(cotherinfo,scartItem)="static"
end sub
'***************************************************************************
' quantity products is in the form
' featureid, quantity; featureid,quantity
' for each entry we add featurename and quantity to the name in the cart
' Set the quantity in the cart to the number in the feature array
'***************************************************************************
'****************************************************************************
Sub CloneProducts (arrcart, scartitem)
dim i, conn
dim words(50),wordcount, values(5),valuecount
scartitem=scartitem
dim Origname, origprice
dim quantityvalues
shopopendatabase conn
origname=arrCart(cProductname,scartItem)
origprice=arrCart(cUnitPrice,scartItem)
parserecord quantityproducts, words, wordcount,";"
for i=0 to wordcount-1
quantityvalues=words(i)
parserecord quantityvalues,values, valuecount,","
featureid=values(0)
quantity=values(1)
If i=0 then
cloneUpdateproduct conn, featureid, quantity, arrcart, scartitem, origname, origprice
else
CloneCreatenewproduct arrcart, scartitem
cloneUpdateproduct conn, featureid, quantity, arrcart, scartitem, origname, origprice
end if
next
shopclosedatabase conn
end sub
'***********************************************************************************
' change quantity and nmae in current array
'***********************************************************************************
Sub cloneUpdateproduct (conn, featureid, quantity, arrcart, scartitem, origname, origprice)
dim tempname
dim productprice, oprice, sfeature
Productprice=origprice
arrCart(cQuantity,scartItem) = quantity
ProcessGetFeatureRecord conn, featureid
If isnull(Curfeatureprice) then curfeatureprice=0
oprice=curfeatureprice
sFeature=" " & CartFeatureCaption & strfeaturecaption & CartFeatureCaptionEnd & " "
sFeature= sFeature & FeatureFont & strfeaturename & FeatureFontEnd
if getconfig("xcurrencysymbol")<>"" and oprice<>"" then
oprice=replace(oprice,getconfig("xcurrencysymbol"),"")
end if
if OPrice<>0 then
If Oprice > 0 then
sFeature = SFeature & FeaturePriceFont & getlang("LangFeatureAdd") & shopformatcurrency(OPrice,getconfig("xdecimalpoint")) & FeaturePriceEnd
else
sFeature = SFeature & FeaturePriceFont & getlang("LangFeatureSubtract") & shopformatcurrency(OPrice,getconfig("xdecimalpoint")) & FeaturePriceEnd
end if
end if
sfeature=sfeature & ""
arrCart(cProductname,scartItem) = Origname & sfeature
'
ProductPrice=Productprice+curFeaturePrice
arrCart(cOriginalPrice,scartItem) = productprice
arrCart(cUnitPrice,scartItem) = ProductPrice
if getconfig("XdualPrice")="Yes" then
Convertcurrency ProductPrice, strDualPrice
arrCart(cDualPrice,scartItem) = strDualprice + TotaloptionDualPrice
end if
end sub
sub CloneCreatenewproduct (arrcart, scartitem)
dim olditem, j
olditem=scartitem
dim cartattributes
cartattributes=cMaxCartAttributes
scartitem=scartitem+1
If scartItem > clng(getconfig("xMaxCartitems")) then
shoperror getlang("Langerror02")
End If
for j=1 to cartattributes
arrCart(j,scartitem) = Arrcart(j,olditem)
' debugwrite "j=" & j & " value=" & arrCart(j,scartitem)
next
end sub
%>