<%Option Explicit%>
[an error occurred while processing this directive]
<%
'***************************************************
' Version 5.00 May 17, 2003
' 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
'*************************************************
'
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
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
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
ResponseRedirect "shoperror.asp?msg=" & Server.URLEncode ( getlang("Langerror02"))
End If
arrCart(cProductid,scartItem) = lngcatalogID
arrCart(cCategory,scartItem) = lngCcategory
arrCart(cProductCode,scartItem) = strccode
arrCart(cGroupDiscount,scartItem) = strgroupfordiscount
AddCartOptions TotalOptionPrice, TotalOptionDualPrice
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
arrCart(cOriginalPrice,scartItem) = OriginalPrice + TotalOptionPrice
arrCart(cUnitPrice,scartItem) = ProductPrice + TotaloptionPrice
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
arrCart(cDualPrice,scartItem) = strDualprice + TotaloptionDualPrice
else
arrCart(cDualPrice,scartItem) = 0
end if
arrCart(cMinimumQuantity,scartItem) = strminimumquantity
arrCart(cSupplierid,scartItem) = strsupplierid
arrCart(cDelivery,scartItem) = ""
if isnull(lngcstock) then
lngcstock=""
end if
If GetSess ("NewProductPrice")="" then
arrCart(cmaximumQuantity,scartItem) = strmaximumquantity
else
arrCart(cmaximumQuantity,scartItem) = 1
end if
arrCart(cStockLevel,scartItem) = lngcstock
arrCart(cProductimage,scartItem) = strcimageurl
arrCart(cProductweight,scartItem) = strweight
arrCart(cProductassociated,scartItem) = ""
arrCart(cProductmininame,scartItem) = strcname
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
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 lquantity, lstock
If getconfig("XCheckStockLevel")<>"Yes" then exit sub
lquantity=clng(quantity)
if isnull(lngcstock) then exit sub
lstock=clng(lngcstock)
If lquantity>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
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)
featurecaption=rs("featurecaption")
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
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
end sub
%>
<%
Sub ConvertCurrency (iamount, oamount)
' VP-ASP 5.0 Feb 4, 2003
'
' Convert currency
dim ydualconversionrate
ydualconversionrate=getconfig("xdualconversionrate")
if not isnumeric(ydualconversionrate) then
exit sub
end if
if ydualconversionrate<>"" then
ydualconversionrate=cdbl(ydualconversionrate)
oamount=iamount*ydualconversionrate
else
oamount=iamount
end if
end sub
%>
<%
'*************************************************************************
' Version 5.00 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
' Feb 4, 2003
'***************************************************************************
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")<>"" then
CustomerPricesinRecord objrs, catalogid, categoryid, ioprice, newprice,discount
exit sub
end if
ShopOpenDatabase custdbc
discount=0
newprice=ioprice
customerid=GetSess("Customerid")
if customerid="" then
exit sub
end if
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
debugwrite "found"
debugwrite lookupsql
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
debugwrite "price=" & price & " discount=" & discount
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
on error goto 0
xdebug=getconfig("xdebug")
if getsess("customertype")="" then exit sub
customerpricefields=getconfig("Xcustomerpricefields")
customerpricetypes=getconfig("Xcustomerpricetypes")
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 customerpricefields="" then exit sub
if customerpricetypes="" then exit sub
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)
SetCustomerPricefield objrs, pricefield, newprice
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
pricefield=fields(i)
SetCustomerPricefield objrs, pricefield, newprice
exit sub
end if
end if
next
end sub
Sub SetCustomerpricefield (objrs, fieldname, price)
dim tprice
tprice=objrs(fieldname)
if isnull(tprice) then exit sub
price=tprice
end sub
%>
<%
'************************************************************
' Version 5.00 Product Formatting
' Fields to be displayed are in shop$colors
' creates a table with columns
' add overallrating
' april 20, 2003
' There are three variations with checkbox, without and with templates
' this routine does NOT handle templates it creates 1 row per product
'*************************************************************
Dim ProdFields
Dim ProdHeaders
Dim QuantityFlag
'**************************************************************************
' format one row
'*********************************************************************
Sub ProductFormatRow
dim url, stayonpage
QuantityFlag=False
If ProductSelect="Yes" then
Response.write ProdRow
ProductFormatFields
if getconfig("xproductcatalogonly")<>"Yes" then
AddSelect
end if
Response.write ""
else
response.write ""
end if
response.write ""
end if
End Sub
'*********************************************************************
' The fields being displayed are configurable in xproductfields
'*****************************************************************
Sub ProductFormatFields
Dim FieldCount
Dim i
Fieldcount=ubound(ProdFields)
for i=0 to FieldCount
FormatProductField ProdFields(i)
next
end sub
'**********************************************************************
' most text fiels are displayed. Some need special format such as currency
'**************************************************************************
Sub FormatProductField (fieldname)
Dim rc, fieldvalue
ProcessSpecial fieldname, rc
If RC=0 then exit sub
Fieldvalue=objRS(fieldname)
response.write ProdColumn & ProdColumnFont & fieldvalue & ProdColumnEnd
end sub
Sub ProcessSpecial (fieldname, rc)
fieldname=ucase(fieldname)
rc=4
Select Case fieldname
Case "CDESCRIPTION"
FormatDescription
rc=0
Case "QUANTITY"
FormatQuantity
rc=0
Case "CPRICE"
FormatPrice
rc=0
end Select
end sub
'
Sub AddSelect
dim rc
if getconfig("xproductcatalogonly")="Yes" then
exit sub
end if
PWriteNoStockMessage rc
if rc> 0 then exit sub
If productwithhtml<>"Yes" Then
response.write "
"
%>
<%
else
%>
<%
end if
End sub
'
Sub FormatName
Response.write ProdNameColumn & ProdNameFont
FormatImage
Formatoverallrating
response.write ProdNameEnd
end sub
Sub FormatDescription
Dim Fieldvalue
Fieldvalue=objRS("cdescription")
response.write ProdDescriptionColumn & ProdDescriptionFont & fieldvalue
FormatProductOptions
FormatUserText
FormatSpecialOffer
FormatCrossSelling
FormatHyperlinks
response.write ProdDescriptionEnd
response.write "
"
end sub
'
Sub FormatQuantity
If strMinimumQuantity=0 or strMinimumquantity="" then
If productwithhtml<>"Yes" Then
Response.write ProdQuantityColumn & "" & ProdQuantityEnd
else
Response.write ""
end if
else
GenerateMinList
end if
QuantityFlag=True
end sub
Sub GenerateMinList
Dim PArray(100),PArrayCount
dim minamount, amount, multiply
minamount=strminimumquantity
'*****************************************************************
' should we generate a list or just prevent the customer from order less
'********************************************************************
If Getconfig("xproductminimumquantity")="Yes" Then
If productwithhtml<>"Yes" Then
Response.write ProdQuantityColumn & "" & ProdQuantityEnd
else
Response.write ""
end if
exit sub
end if
parraycount=getconfig("xproductminimumlist")
if parraycount="" then
parraycount=6
end if
parraycount=clng(parraycount)
for i = 1 to parraycount
amount=i*minamount
parray(i)=amount
next
dim i
sSelect = ""
If productwithhtml<>"Yes" then
Response.write ProdQuantityColumn & sSelect & ProdQuantityend
else
Response.write sSelect
end if
end sub
Sub FormatPrice
Dim OriginalPrice, decimalpoint
dim savings, displaysavings
If getconfig("XDisplayPrices")="No" then exit sub
displaysavings=getconfig("xproductdisplaysaving")
dim strPrice, newprice
' if we read product in getproduct values all this has been done
If ProductFieldvalid<>True then
lngcatalogid=objrs("catalogid")
lngccategory=objrs("ccategory")
curcprice=objrs("cprice")
NewPrice=curCPrice
curOriginalPrice=curCprice
ShopCustomerPrices objrs,lngcatalogid, lngCcategory, CurCprice, Newprice, lngDiscount
curCPrice=Newprice
end if
decimalpoint=getconfig("xdecimalpoint")
strPrice=shopformatcurrency(curCprice,decimalpoint)
response.write ProdColumnPrice & ProdColumnFont & strPrice
If not isnull(objrs("retailprice")) then
if strRetailPrice> 0 then
If Displaysavings<>"Yes" Then
response.write ProdRetailPriceStart & getlang("langProductRetailPrice") & shopformatcurrency(strRetailPrice,decimalpoint) & ProdRetailPriceEnd
else
savings=strRetailprice-strprice
response.write ProdRetailPriceStart & getlang("langProductRetailPrice")
response.write shopformatcurrency(strRetailPrice,decimalpoint)
response.write " " & getlang("langProductPriceSaving") & " " & shopformatcurrency(savings,decimalpoint)
response.write ProdRetailPriceEnd
end if
end if
end if
If getconfig("xDisplayOriginalPrice")="Yes" and lngdiscount<>0 then
response.write ProdOriginalPriceStart & getlang("langProductBasePrice") & shopformatcurrency(curOriginalPrice,decimalpoint) & ProdOriginalPriceEnd
end if
Response.write ProdPriceEnd
If getconfig("xDualPrice")="Yes" then
FormatDualPrice
end if
end sub
'**************************************************************
' dual price is normally computed but may come from product record itself
'****************************************************************
Sub FormatDualPrice
Dim strPrice
If strcdualprice="" then
ConvertCurrency curCprice, strPrice
else
strprice=strcdualprice
end if
strPrice=FormatNumber(strprice,2)
response.write ProdColumnPrice & ProdColumnFont & strPrice
Response.write ""
end sub
'*********** Format Image and Extended Description
Sub FormatImage
'*******************************************************
' if product has an image, it is formatted here
'******************************************************
if isnull(strcimageurl) then
strcimageurl=""
end if
if isnull(strDescurl) then
strdescurl=""
end if
If strDescURL<>"" then
If getconfig("xAddCatalogid")="Yes" then
strDescURL=strDescURL & "?id=" & lngCatalogID
end if
else
If getconfig("xGenerateShopexdLink")="Yes" then
strdescurl="shopexd.asp"
strDescURL=strDescURL & "?id=" & lngCatalogID
end if
end if
'exit sub if both empty, no piont going further
If strdescurl="" and strcimageurl="" then
exit sub
end if
'
If strcImageUrl<>"" then
GenerateImage
else
GenerateNoImage
end if
end sub
'
Sub GenerateImage
If strDescUrl<>"" then
If Getconfig("XextendedPopup")="Yes" then
%>
<%
end if
end sub
'
Sub GenerateNoImage
dim buttonimage
buttonimage=Getconfig("xbuttonmoreinfo")
if isNull(buttonimage) Or buttonimage="" then
buttonimage=""
end if
If Getconfig("XextendedPopup")="Yes" then
If buttonimage="" Then
%>
<%
End if
end if
end sub
'
Sub FormatButton
'******************************************************
' If product has a button image
' it is formatted here
'******************************************************
dim mybutton
Dim mytext
dim rc
if getconfig("xproductcatalogonly")="Yes" then
exit sub
end if
PWriteNoStockMessage rc
if rc> 0 then exit sub
mytext=getconfig("XButtonText")
if mytext="" then
mytext="Order"
end if
mybutton=""
' If strButtonimage is not null use it
' If Sess("buttonimage") is not null use it otherwise you normall button
If productwithhtml<>"Yes" Then
Response.write ProdButtonColumn
end if
if strButtonImage<>"" Then
mybutton= strbuttonimage
else
if getconfig("xButtonImage") <>"" then
mybutton=getconfig("xbuttonimage")
end if
end if
If myButton="" then
response.write "
"
exit sub
end if
response.write "
"
If productwithhtml<>"Yes" then
response.write ""
end if
end sub
'
Sub FormatSpecialOffer
if strSpecialOffer<>"" then
Response.write " " & prodspecialcolor & strSpecialOffer & prodspecialend
end if
end sub
Sub ProductFormatHeader
'*************************************
' Headers for product are displayed here
'**************************************
Dim FieldCount
Dim I
SetupProductFields ProdFields, ProdHeaders
Fieldcount=ubound(ProdHeaders)
Response.write ProdTable
Response.write ProdHeaderRow
for i=0 to FieldCount
if getlang("langProductPrice")=ProdHeaders(i) then
If getconfig("XDisplayprices")="Yes" Then
FormatProductHeaders ProdHeaders(i)
if getconfig("xDualPrice")="Yes" then
FormatProductHeaders getlang("langDualPrice")
end if
end if
else
FormatProductHeaders ProdHeaders(i)
end if
next
if getconfig("xproductcatalogonly")<>"Yes" then
IF productSelect="Yes" then
FormatProductHeaders getlang("langProductSelect")
else
If getconfig("xproductcatalogonly")<>"Yes" then
FormatProductHeaders getlang("langProductOrder")
end if
end if
end if
response.write "
"
end sub
'
Sub FormatProductHeaders (Name)
Response.write ProdHeaderColumn & Name & ProdHeaderColumnEnd
end sub
Sub PWriteNoStockMessage (rc)
rc=0
if getconfig("xOutOfStockLimit")="" then exit sub
if isnull(lngcstock) then exit sub
if lngcstock>clng(getconfig("xOutOfStocklImit")) then exit sub
If productwithhtml="Yes" then
Response.write getlang("langOutOfStock")
else
Response.write OutofStockColumn & getlang("langOutOfStock") & OutofStockColumnEnd
end if
rc=4
end sub
'****************************************************************
' see if product has any cross selling products
'***************************************************************
Sub FormatCrossSelling
dim lncstock
dim strCrossProductIDs,strsql, rs, strmessage, strcdescurl,strurl
If getconfig("XCrossSelling")<>"Yes" then exit sub
strcrossproductids=objrs("crossselling")
if isnull(strCrossProductids) then exit sub
strsql="select * from products where catalogid in (" & strcrossproductids & ")"
strsql=strsql & " and hide=0"
if getconfig("xstocklow")<>"" then
lngcstock= clng(getconfig("xstocklow"))
strsql = strsql & " and cstock> " & lngcstock
end if
set rs=dbc.execute(strsql)
While Not rs.EOF
strCDescURL=rs("cdescurl")
If isnull(Strcdescurl) then
strCDescURL=getconfig("xCrossLinkURL")
end if
if ucase(strcDESCURL)="SHOPEXD.ASP" then
strurl="shopexd.asp?id=" & rs("catalogid")
Else
strurl="shopquery.asp?catalogid=" & rs("catalogid")
End if
strMessage=strMessage & " " & ""
RS.MoveNext
WEND
RS.Close
set RS=Nothing
strMessage=" " & getlang("langCrossSellingMessage") & strMessage
Response.write strmessage
end sub
Sub FormatHyperlinks
dim strmessage, breaker, strurl
breaker=" "
If getconfig("xProductLinkTellaFriend")="Yes" then
strurl="shoptellafriend.asp?id=" & lngcatalogid
If getconfig("xbuttontellafriend")<>"" then
strmessage=breaker & ""
else
strMessage=breaker & "" & getlang("langTellaFriend") & ""
end if
Response.write ReviewHyperlinkFont
breaker=" "
response.write strMessage
Response.write ReviewHyperlinkFontEnd
end if
If getconfig("xRatingproducthyperlink")="Yes" then
Response.write ReviewHyperlinkFont
strurl="shopreviewadd.asp?id=" & lngcatalogid
If getconfig("xbuttonwritereview")<>"" then
strmessage=breaker & ""
else
strMessage=breaker & "" & getlang("langRatingWrite") & ""
end if
breaker=" "
response.write strMessage
strurl="shopreviewlist.asp?id=" & lngcatalogid
If getconfig("xbuttonreadreview")<>"" then
strmessage=breaker & ""
else
strMessage=breaker & "" & getlang("langRatingRead") & ""
end if
breaker=" "
response.write strMessage
Response.write ReviewHyperlinkFontEnd
end if
end sub
'
Sub FormatOverallrating
dim oaverage,image, count
If getconfig("xAllowRatingProducts")<>"Yes" then exit sub
If getconfig("xAllowRatingSummary")<>"Yes" then exit sub
Reviewaverage lngcatalogid, oaverage,image, count, dbc
If image="" then
response.write "
<%
'**************************************************
' obtain average rating and image
' VP-ASP 5.0
' Jan 5, 2003
'*****************************************************
Sub ReviewAverage(catalogid, oaverage, image, outcount, dbc)
dim rs, rsql, strrating
rsql=" SELECT catalogid, Avg(rating) AS avgofrating, count(catalogid) as countcatalogid from reviews where catalogid=" & catalogid & " AND authorized IS NOT NULL GROUP BY catalogid"
set rs=dbc.execute(rsql)
if not rs.eof then
oaverage=rs("avgofrating")
oaverage=clng(oaverage)
strrating=cstr(oaverage)
outcount=rs("countcatalogid")
Select case strrating
Case "1"
image="vpasp_stars1.gif"
Case "2"
image="vpasp_stars2.gif"
Case "3"
image="vpasp_stars3.gif"
Case "4"
image="vpasp_stars4.gif"
Case "5"
image="vpasp_stars5.gif"
Case else
image=""
end select
else
oaverage=""
image=""
end if
rs.close
set rs=nothing
end sub
%>
<%
dim xSearchSortField,xsearchsortupdown
Sub ProductCreateSQL (sql, dbc)
'*****************************************************
' VP-ASP 5.00 April 21, 2003
' Generates SQL to display a product.
' Creates SQL for dispaly products, search and shopquery
' expects most parameters to be in global
'*****************************************************
sql=""
dim strProductFields
dim i
dim strdistinct
strdistinct="DISTINCTROW"
if UCASE(xdatabasetype)="SQLSERVER" or ucase(getconfig("xdatabasetype"))="SQLSERVER" then
strdistinct="DISTINCT"
end if
strProductFields=Getsess("strProductFields")
If strProductFields="" then
GetProductfields dbc
strProductFields=Getsess("strProductFields")
end if
If getconfig("xCategoriesSimple")="Yes" then
NewProductSQL sql
exit sub
end if
sql="select " & strdistinct & " " & strproductfields
sql=sql & " from products p, prodcategories cc, categories c"
sql=sql & " where cc.intcatalogid=p.catalogid and cc.intcategoryid=c.categoryid and"
if cat_id <> "" then
sql = sql & " cc.intcategoryid = " & cat_id
else
if catalogid<>"" then
sql = sql & " p.catalogid = " & catalogid
else
if productname="" then
sql = sql & " c.catdescription like '"& category & "%'"
else
sql = sql & "p.cname like '"& productname & "%'"
end if
end if
end if
sql=sql & " and hide=0 "
if getconfig("xstocklow")<>"" then
lngcstock= clng(getconfig("xstocklow"))
sql = sql & " and cstock> " & lngcstock
end if
if getconfig("xproductmatch")="Yes" then
sql=sql & " and (p.productmatch='" & xproductmatch & "'"
sql=sql & " or p.productmatch is null)"
end if
if getconfig("xproductmatchcustomer")="Yes" then
if GetSess("CustomerProductGroup")<>"" then
sql=sql & " and (p.customermatch like '%" & getsess("customerProductgroup") & "%'"
sql=sql & " or p.customermatch is null)"
else
sql=sql & " and p.customermatch is null"
end if
end if
If getconfig("xselectproductsbylanguage")="Yes" and getsess("language")<>"" then
sql=sql & " and (clanguage='" & getsess("language") & "'"
sql=sql & " or clanguage is null)"
end if
sql = sql & " order by " & getconfig("xsortproducts")
'SetSess "SQL", sql
if getconfig("xdebug")="Yes" then
debugwrite sql
end if
end sub
Sub SearchGenerateSQL(dbc)
dim i, j
dim whereok
Dim SearchFields
dim Fieldcount
dim strdistinct
strdistinct="DISTINCTROW"
if UCASE(xdatabasetype)="SQLSERVER" or ucase(getconfig("xdatabasetype"))="SQLSERVER" then
strdistinct="DISTINCT"
end if
If getconfig("xCategoriesSimple")="Yes" then
NewSearchGenerateSQL sql
exit sub
end if
SetupSearchFields SearchFields
Fieldcount=ubound(Searchfields)
whereok=" AND "
dim strProductFields, tmpstr
GetProductFields dbc
strProductFields=Getsess("strProductFields")
tmpstr="select " & strdistinct & " " & strproductfields & " from products p, prodcategories cc, prodcategories sc, categories c"
sql= " where cc.intcatalogid=p.catalogid and cc.intcategoryid=c.categoryid AND sc.intcatalogid=p.catalogid"
if wordcount> 0 then
SQL = SQL & whereok
SQL = SQL & "("
Whereok=""
for i = 0 to wordcount-1
SQL=SQL & whereok
For j=0 to fieldcount
If j> 0 then
SQL = SQL & " OR "
else
SQL=SQL & " ( "
end if
SQL = SQL & Searchfields(j) & " Like '%" & words(i) & "%' "
next
SQL = SQL & " )"
whereok=" OR "
next
SQL = SQL & ")"
whereok=" AND "
end if
if catCount<>0 then
SQL=SQL & whereok
SQL = SQL & " ("
whereok=""
for i =0 to catcount-1
sql = sql & whereok & " cc.intcategoryid = " & catarray(i)
whereOK=" OR "
next
Sql=Sql & ")"
whereok=" AND "
end if
if SubcatCount<>0 then
SQL=SQL & whereok
SQL = SQL & " ("
whereok=""
dim blnSubcat
blnSubCat=False
for i =0 to Subcatcount-1
sql=sql & whereok & "sc.intcategoryid" & "=" & subcatarray(i)
whereOK=" OR "
blnSubCat=True
next
Sql=Sql & ")"
whereok=" AND "
end if
'
Sql=Sql & whereok
sql=sql & " hide=0"
whereok=" AND "
if getconfig("xstocklow")<>"" then
lngCStock= clng(getconfig("xStockLow"))
SQL= SQL & WhereOK
sql = sql & " cstock> " & lngcstock
whereok=" AND "
end if
if getconfig("xproductmatch")="Yes" then
SQL= SQL & WhereOK
sql=sql & " ( p.productmatch='" & xproductmatch & "'"
sql=sql & " or p.productmatch is null)"
whereok=" AND "
end if
if getconfig("xproductmatchcustomer")="Yes" then
if GetSess("CustomerProductGroup")<>"" then
SQL= SQL & WhereOK
sql=sql & " (p.customermatch like '%" & getsess("customerProductgroup") & "%'"
sql=sql & " or p.customermatch is null)"
whereok=" AND "
else
SQL= SQL & WhereOK
sql=sql & " p.customermatch is null"
whereok=" AND "
end if
end if
If getconfig("xselectproductsbylanguage")="Yes" and getsess("language")<>"" then
sql=sql & " and (clanguage='" & getsess("language") & "'"
sql=sql & " or clanguage is null)"
end if
'added for search sort 3 April 2002n
If xSearchSortField<>"" Then
sql = sql & " order by " & xSearchSortField & " " & xsearchsortupdown
Else
sql = sql & " order by " & getconfig("xSortProducts")
End If
sql=tmpStr & sql
SetSess "SQL",SQL
SetSessA "words",Words
SetSess "wordcount",wordcount
if getconfig("xdebug")="Yes" then
debugwrite sql
end if
end sub
Sub QueryGenerateSQl (dbc)
dim i
dim rc
dim strProductFields
dim strdistinct
strdistinct="DISTINCTROW"
if UCASE(xdatabasetype)="SQLSERVER" or ucase(getconfig("xdatabasetype"))="SQLSERVER" then
strdistinct="DISTINCT"
end if
If getconfig("xCategoriesSimple")="Yes" then
NewQueryGenerateSQL
exit sub
end if
strProductFields=Getsess("strProductFields")
If strProductFields="" then
GetProductFields dbc
strProductFields=Getsess("strProductFields")
End If
tmpstr="select " & strdistinct & " " & strproductfields & " from products p, prodcategories cc, categories c "
'on error resume next
firsttime="FALSE"
sql=" where cc.intcatalogid=p.catalogid and cc.intcategoryid=c.categoryid "
for i=0 to keycount-1
AddSQL Keys(i), keyvalues(i), SQL
Next
AddPrefix
sql=sql & " hide=0"
if getconfig("xstocklow")<>"" then
lngCStock= clng(getconfig("xStockLow"))
AddPrefix
sql = sql & " cstock > " & lngcstock
end if
if getconfig("xproductmatch")="Yes" then
AddPrefix
sql=sql & " p.productmatch='" & xproductmatch & "'"
end if
if getconfig("xproductmatchcustomer")="Yes" then
if GetSess("CustomerProductGroup")<>"" then
AddPrefix
sql=sql & " (p.customermatch like '%" & getsess("customerProductgroup") & "%'"
sql=sql & " p.customermatch is null"
whereok=" AND "
else
AddPrefix
sql=sql & " p.customermatch is null"
whereok=" AND "
end if
end if
If getconfig("xselectproductsbylanguage")="Yes" and getsess("language")<>"" then
sql=sql & " and clanguage='" & getsess("language") & "'"
end if
If getconfig("xsortproducts")<>"" then
sql = sql & " ORDER BY " & getconfig("xSortProducts")
end if
sql=tmpStr & sql
if getconfig("xdebug")="Yes" then
debugwrite sql
end if
end sub
Sub addPrefix
if firsttime="TRUE" then
SQL=SQL & " WHERE "
firsttime="FALSE"
else
SQL = SQL & " AND "
end if
end sub
Sub GetProductFields (dbc)
dim sortfields, strproductfields
strproductfields="p.catalogid"
sortfields=lcase(getconfig("xsortproducts"))
sortfields=replace(sortfields," asc","")
sortfields=replace(sortfields," desc","")
if sortfields<>"" Then
strproductfields=strproductfields & "," & sortfields
end if
setsess "strProductFields", strProductFields
end sub
SUB AddSQL (strname,strvalue, SQL)
dim fieldtype, istrname
ustrname=Ucase(strname)
CheckValidField ustrname, rc, fieldtype
if rc>0 then
exit sub
end if
if Fieldtype ="Number" or FieldType="Currency" then
end if
if fieldtype="Text" or fieldtype="Memo" then
If ucase(strvalue)=allvalues then ' make all really mean all
strvalue=""
end if
addprefix
SQL=SQL & " p." & strname & " like '" & strvalue & "%'"
exit sub
end if
If Fieldtype="DateTime" then
addprefix
SQL=SQL & " p." & strname & "=#" & cdate(strvalue) & "#"
exit sub
end if
If Fieldtype="Currency" then
if strvalue<0 then
exit sub
end if
If not IsNumeric(strvalue) then
exit sub
end if
if getconfig("xConvertEuropeanNumbers")="Yes" then
strvalue=replace(strvalue,",",".")
end if
'strvalue=Formatnumber(strvalue,2)
addprefix
If strname<>"lowprice" then
SQL=SQL & " p." & strname & "<=" & strvalue
else
SQL=SQL & " p.cprice>=" & strvalue
end if
exit sub
end if
if Fieldtype ="Number" then
If strvalue<0 then
exit sub
end if
If not IsNumeric(strvalue) then
exit sub
end if
addprefix
SQL=SQL & " p." & strname & "=" & strvalue
exit sub
end if
addprefix
SQL=SQL & " p." & strname & " like '" & strvalue & "%'"
end sub
'
Sub addPrefix
if firsttime="TRUE" then
SQL=SQL & " WHERE "
firsttime="FALSE"
else
SQL = SQL & " AND "
end if
end sub
'**********************************************************
' dont use prod categories table
'************************************************************
Sub NewProductSQL(sql)
sql = "select * from products where "
if cat_id <> "" then
sql = sql & " ccategory = " & cat_id & " or subcategoryid = " & cat_id
else
if catalogid<>"" then
sql = sql & " catalogid = " & catalogid
else
if productname="" then
sql = sql & "category like '"& category & "%'"
else
sql = sql & "cname like '"& productname & "%'"
end if
end if
end if
if subcat<> "" then
' sql = sql & " and subcategoryid=" & subcat
end if
sql = sql & " and hide=0"
if getconfig("xstocklow")<>"" then
lngcstock= clng(getconfig("xstocklow"))
sql = sql & " and cstock> " & lngcstock
end if
if getconfig("xproductmatch")="Yes" then
sql=sql & " and productmatch='" & xproductmatch & "'"
end if
if getconfig("xproductmatchcustomer")="Yes" then
if GetSess("CustomerProductGroup")<>"" then
sql=sql & " and customermatch='" & getsess("customerProductgroup") & "'"
end if
end if
If getconfig("xselectproductsbylanguage")="Yes" and getsess("language")<>"" then
sql=sql & " and clanguage='" & getsess("language") & "'"
end if
sql = sql & " order by " & getconfig("xsortproducts")
'debugwrite sql
end sub
'***********************************************************
' Simple category mode for searches
'************************************************************
Sub NewSearchGenerateSQL(sql)
dim i, j
dim whereok
Dim SearchFields
dim Fieldcount
SetupSearchFields SearchFields
Fieldcount=ubound(Searchfields)
whereok=" WHERE "
SQL = "SELECT * FROM products "
if wordcount> 0 then
SQL = SQL & whereok
SQL = SQL & "("
Whereok=""
for i = 0 to wordcount-1
SQL=SQL & whereok
For j=0 to fieldcount
If j> 0 then
SQL = SQL & " OR "
else
SQL=SQL & " ( "
end if
SQL = SQL & Searchfields(j) & " Like '%" & words(i) & "%' "
next
SQL = SQL & " )"
whereok=" OR "
next
SQL = SQL & ")"
whereok=" AND "
end if
if catCount<>0 then
SQL=SQL & whereok
SQL = SQL & " ("
whereok=""
for i =0 to catcount-1
sql = sql & whereok & " ccategory = " & catarray(i)
whereOK=" OR "
next
Sql=Sql & ")"
whereok=" AND "
end if
if SubcatCount<>0 then
SQL=SQL & whereok
SQL = SQL & " ("
whereok=""
for i =0 to Subcatcount-1
sql = sql & whereok & " subcategoryid = " & subcatarray(i)
whereOK=" OR "
next
Sql=Sql & ")"
whereok=" AND "
end if
Sql=Sql & whereok
sql=sql & " (hide=0)"
whereok=" AND "
if getconfig("xstocklow")<>"" then
lngCStock= clng(getconfig("xStockLow"))
SQL= SQL & WhereOK
Sql = sql & " cStock> " & lngCStock
whereok=" AND "
end if
if getconfig("xproductmatch")="Yes" then
SQL= SQL & WhereOK
sql=sql & " productmatch='" & xproductmatch & "'"
whereok=" AND "
end if
if getconfig("xproductmatchcustomer")="Yes" then
if GetSess("CustomerProductGroup")<>"" then
SQL= SQL & WhereOK
sql=sql & " customermatch='" & getsess("customerProductgroup") & "'"
end if
end if
If getconfig("xselectproductsbylanguage")="Yes" and getsess("language")<>"" then
sql=sql & " and clanguage='" & getsess("language") & "'"
end if
sql = sql & " order by " & getconfig("xSortProducts")
SetSess "SQL",SQL
SetSessA "words",Words
SetSess "wordcount",wordcount
'debugwrite SQL
end sub
'****************************************************
' simple category mode for shopquery
'***************************************************
Sub NEWQuerygenerateSQl
on error resume next
firsttime="TRUE"
SQL = "SELECT * FROM products "
if getconfig("xstocklow")<>"" then
lngCStock= clng(getconfig("xStockLow"))
oldaddprefix
SQL = SQL & " cStock> " & lngCStock
end if
for i=0 to keycount-1
oldAddSQL Keys(i), keyvalues(i), SQL
Next
oldaddprefix
sql=sql & " (hide is NULL OR hide=0)"
if getconfig("xproductmatch")="Yes" then
oldaddprefix
sql=sql & " productmatch='" & xproductmatch & "'"
end if
if getconfig("xproductmatchcustomer")="Yes" then
if GetSess("CustomerProductGroup")<>"" then
oldaddprefix
sql=sql & " customermatch='" & getsess("customerProductgroup") & "'"
whereok=" AND "
end if
end if
If getconfig("xselectproductsbylanguage")="Yes" and getsess("language")<>"" then
oldaddprefix
sql=sql & " clanguage='" & getsess("language") & "'"
end if
sql = sql & " ORDER BY " & getconfig("xSortProducts")
if getconfig("xdebug")="Yes" then
debugwrite sql
end if
end sub
%>
<%
Sub HtmlProductFormatRow
'**********************************************************************************
' A template tmp_productformat.htm is supplied. It is used to format
' products. Special keywords in the form
' [ formatimage sub]
' [Formatproductoptions sub]
' [formatquantity sub]
' [formathyperlinks sub]
' formatoverallrating sub]
' VP-ASP 5.00 Jan 3, 2003
'**************************************************************
' objrs is already opened pointing to record
dim template, rc, url, stayonpage
StartColumnOrRow
template=GetProductTemplate
If Template="" then
Serror=getlamg("LangExdNoTemplate")
shoperror serror
end if
If ProductSelect<>"Yes" then
response.write ""
end if
response.write ""
end if
EndColumnOrRow
end sub
'
Sub HtmlProductFormatHeader
'*************************************
' Headers for product are displayed here
' VP-ASP 4.00
' June 2, 2002
'**************************************
Response.write Prodtable
colcount=0
end sub
Sub StartColumnorRow
'debugwrite "colcount=" & colcount & "maxcolumns=" & productmaxcolumns
If ProductMaxColumns=1 or colcount=0 then
Response.write prodrow
end if
response.write "
"
end sub
Sub EndColumnorRow
If ProductMaxColumns=1 then
response.write "
"
Response.write ""
exit sub
end if
Response.write "
"
end sub
Sub Handle_Product (isub)
select case isub
Case "FORMATIMAGE"
Formatimage
Case "FORMATBUTTON"
If ProductSelect="Yes" then
AddSelect
else
Formatbutton
end if
Case "FORMATHYPERLINKS"
Formathyperlinks
Case "FORMATOVERALLRATING"
Formatoverallrating
Case "FORMATPRODUCTOPTIONS"
Formatproductoptions
Case "FORMATQUANTITY"
Formatquantity
case else
debugwrite "Unknown sub"
end select
end sub
'************************************************************************
' templates can be passed as request variables
' They can be dependent on the category being displayed
'*************************************************************************
Function GetProductTemplate
dim template, rtemplate, sql, rs, query
rtemplate=request("template")
If rtemplate<>"" then
template=rtemplate
Getproducttemplate=template
exit function
end if
template=getconfig("xproductdisplaytemplate")
If getconfig("xcategoryproducttemplates")="No" then
Getproducttemplate=template
exit function
end if
' because we are really part of shopdisplayproducts we can use open connect and cat_id
If cat_id<>"" then
query = "select * from categories where categoryid = " & cat_id
set rs = dbc.execute(query)
If not rs.EOF Then
rtemplate = rs("catproducttemplate")
if isnull(rtemplate) then
rtemplate=template
end if
template=rtemplate
end if
rs.close
set rs=nothing
End if
Getproducttemplate=template
end function
%>
<%
const pfieldnames=1
const pfieldvalues=2
const pfieldtypes=3
const pfieldcount=4
const ptableflag=5
const ptemplatedisplay=6
const ptemplaterray=7
const ptokenformat=8
const pidfield=9
const pidvalue=10
const ptokens=11
const pdatacurrentrecord=12
const pdata=13
const pdatarecordcount=14
const pdatainmemory=15
const pparseattributes=16
'***********************************************************************
' VP-ASP 5.00 Merge templates with database
' May 25, 2003
'
'**********************************************************************
' Template handling Version 5.00
' "ADD_OITEMS"
' "ADD_PAGEHEADER"
' "ADD_PAGETRAILER"
' "SPECIAL_ORDERBUTTON"
' "SPECIAL_CHECKBOX"
' "ADD_FORMSTART"
' "ADD_FORMEND"
' "ADD_PRODUCTFEATURES"
' "ADD_QUANTITY"
' "ADD_ORDERBUTTON"
' "ADD_CHECKBOX"
' "ADD_TABLE"
' "ADD_TABLEEND"
' "ADD_PRODUCT"
' "ADD_CROSSSELLING"
' "file=filename INCLUDE"
' "field=fieldname INCLUDE
' "ADD_OITEMSTEMPLATE"
'
' Does field substitution from database to a text template
' TemplateDisplay Yes = output to browser
' No put into array
'**********************************************************
'**************************************************************
' filename to be opened
' rc=4 if file cannot be found
' returns fsObj and RecordObj
'*************************************************************
Sub OpenInputFile (filename, fsObj, RecordObj, rc)
on error resume next
Dim whichfile, dbfile
dbfile=left(filename,3)
If lcase(dbfile)="db=" then
OpenInputFiledb filename, fsObj, RecordObj, rc
exit sub
end if
whichfile=server.mappath(filename)
set fsObj = Server.CreateObject("Scripting.FileSystemObject")
set RecordObj= fsObj.OpenTextFile(whichfile, 1, False)
If err.number > 0 then
rc=4
fsObj.close
set fsObj=nothing
else
rc=0
' debugwrite whichfile & " opened ok "
end if
End sub
'
' close a file
Sub CloseFile (fsObj, RecordObj, rc, parsearray)
If parsearray(pdatainmemory)="Yes" then exit sub
set RecordObj = nothing
set fsObj = nothing
rc=0
end sub
'
' reads and entire file template into a memory array
'
' creates and array of converted records
Sub ShopTemplateArray(Filename, RS, Outarray, Outcount)
dim parsearray, fieldnames, fieldvalues, fieldtypes, fieldcount
redim fieldnames(100)
redim fieldvalues(100)
redim fieldtypes(100)
redim parsearray(Pparseattributes)
Dim i
Dim NewRecord
Dim fs,ts
Dim rc
Dim Bypass
Dim tempcount
OpenInputFile Filename, fs, ts, rc
If rc> 0 then
shopwriteError getlang("LangReadFail") & filename
exit sub
end if
GetFieldValues RS, fieldnames, fieldvalues, fieldtypes, fieldcount
dim Temparray
tempcount=ubound(outarray)
redim temparray(tempcount)
outcount=0
SetupParseArray Parsearray, filename, rs, fieldnames, fieldvalues, fieldtypes, fieldcount, fs, ts
ReadEntireFile fs, ts, Tempcount, TempArray, parsearray
CloseFile fs,ts, rc, parsearray
for i = 0 to tempcount - 1
Substitute Temparray(i), NewRecord, Bypass, parsearray, rs
If Bypass=False then
OutArray(outcount)=NewRecord
outcount=outcount+1
end if
next
end sub
'
Sub SetupParseArray (Parsearray, filename, rs, fieldnames, fieldvalues, fieldtypes, fieldcount, fsoobj,recordobj)
dim data, datacount, rc, dbfieldname
redim parsearray(Pparseattributes)
parsearray(pfieldnames)=fieldnames
parsearray(pfieldvalues)=fieldvalues
parsearray(pfieldtypes)=fieldtypes
parsearray(pfieldcount)=fieldcount
parsearray(ptableflag)=""
parsearray(ptemplatedisplay)="No"
parsearray(pidfield)=rs(0).name
parsearray(pidvalue)=rs(0).value
parsearray(pdatarecordcount)=0
parsearray(pdatainmemory)=""
CheckFiledb filename,dbfieldname,rc
If rc=0 then
redim data(500)
ReadEntireFileDB fsoobj, RecordObj, datacount,data,parsearray
parsearray(pdata)=data
parsearray(pdatarecordcount)=datacount
parsearray(pdatacurrentrecord)=0
parsearray(pdatainmemory)="Yes"
end if
end sub
'****************************************************************
' writes each record to browser
'***************************************************************
Sub ShopTemplateWrite(Filename, RS, orc)
Dim i
Dim NewRecord
Dim recordObj, FsObj
dim rc
Dim MyText
dim readcount
Dim Bypass
OpenInputFile Filename, fsObj, RecordObj, rc
If rc> 0 then
shopwriteError getlang("LangReadFail") & filename
orc=4
exit sub
end if
dim parsearray, fieldnames, fieldvalues, fieldtypes, fieldcount
redim fieldnames(150)
redim fieldvalues(150)
redim fieldtypes(150)
redim parsearray(Pparseattributes)
readcount=0
GetFieldValues RS, fieldnames, fieldvalues, fieldtypes, fieldcount
'For i = 0 to fieldcount
' debugwrite fieldnames(i) & "=" & fieldvalues(i)
'next
SetupParseArray Parsearray, filename, rs, fieldnames, fieldvalues, fieldtypes, fieldcount, fsobj, recordobj
Parsearray(pTemplateDisplay)="Yes"
ReadARecord RecordObj, MyText, rc, parsearray
Do while rc=0
Substitute mytext, NewRecord, Bypass, parsearray, rs
If Bypass=False then
Response.write NewRecord & vbcrlf
end if
'debugwrite "old=" & Mytext & " new=" & NewRecord
readcount=readcount+1
ReadARecord RecordObj, MyText, rc, parsearray
' Response.write Server.HTMLEncode(mytext) & " "
Loop
CloseFile fsObj,RecordObj, rc, parsearray
orc=0
end sub
'
Sub ReadEntireFile (fsoobj, RecordObj, readcount, readarray,parsearray)
'on error resume next
dim rc
dim mytext, data, i
If parsearray(pdatainmemory)="Yes" Then
data=parsearray(Pdata)
for i = 0 to parsearray(pdatarecordcount)-1
readarray(i)=data(i)
next
readcount=parsearray(pdatarecordcount)
exit sub
end if
rc=0
readcount=0
ReadARecord RecordObj, MyText, rc, parsearray
'Response.write Server.HTMLEncode(mytext) & " "
'Debugwrite myText
Do while rc=0
readarray(readcount)=mytext
readcount=readcount+1
ReadARecord RecordObj, MyText, rc, parsearray
'Response.write Server.HTMLEncode(mytext) & " "
Loop
end sub
'
Sub ReadARecord (RecordObj, record, rc,parsearray)
If parsearray(Pdatainmemory)="Yes" then
ReadARecordDB RecordObj, record, rc,parsearray
exit sub
end if
if RecordObj.AtEndofStream then
rc=4
exit sub
end if
record = RecordObj.readline
rc=0
End Sub
Function Find_Replace(srchString, FndString, InsertString, strend )
Dim i, LastChar, Next_Pos
Dim CurrentPos, LastPos
Dim tempstring
If strend > 0 Then
LastChar = strend
Else
LastChar = Len(srchString)
End If
tempstring = srchString
Next_Pos = 0
Next_Pos = InStr(Next_Pos + 1, tempstring, FndString)
Do Until (Next_Pos = 0) Or (Next_Pos > LastChar)
tempstring = Left(tempstring, Next_Pos - 1) & InsertString & Right(tempstring, (Len(tempstring) - Len(FndString) - (Next_Pos - 1)))
LastChar = LastChar - Len(FndString) + Len(InsertString)
Next_Pos = 0
Next_Pos = InStr(Next_Pos + 1, tempstring, FndString)
Loop
Find_Replace = tempstring
End Function
'
Sub Substitute (inrecord, workrecord, Bypass, parsearray, parseRS)
' values can be any field in the products table
' or special keywords
' [field]
' [
dim tokenformat
dim tokens(5)
dim tokencount
Dim rc
Dim morefields
Dim dbindex
Dim dbfieldname
Dim dbvalue
Dim dbvalue1
Dim token
Dim Newrecord
Dim fieldfound
Dim pos
Dim endpos
Dim specchar
Dim dbvalue2
Dim firstchar
Dim length
pos = 1
Bypass=False
'Response.write "converting " & Server.HTMLEncode(inrecord) & " "
workrecord = inrecord
morefields = True
fieldfound = False ' used to determine if record is ouput if starts with a $
firstchar = Left(workrecord, 1) ' save first character
Do While morefields = True
pos = InStr(pos, workrecord, "[")
If pos > 0 Then
endpos = InStr(pos, workrecord, "]")
If endpos=0 then
WriteError "Missing ] on field starting at " & Pos
morefields=false
else
length = endpos - pos + 1
tokenformat=""
token = Mid(workrecord, pos, length)
specchar = Mid(token, 2, 1)
dbfieldname = Mid(token, 2, length - 2)
parserecord dbfieldname, tokens, tokencount, " "
if tokencount> 1 then
dbfieldname=tokens(1)
tokenformat=ucase(tokens(0)) ' formatcurrency, formatnumber
'debugwrite "tokenformat=" & tokenformat & " token=" & token
end if
Parsearray(ptokenformat)=tokenformat
Parsearray(ptokens)=tokens
FindField dbfieldname, dbvalue, rc, parsearray, parseRS
If rc > 0 Then Exit Sub
Newrecord = Find_Replace(workrecord, token, dbvalue, 0)
If dbvalue <> "" Then
fieldfound = True ' used to determine if record written
End If
workrecord = Newrecord
end if
Else
morefields = False
End If
Loop
' at this point if record starts with a $ and no fields substituted, do not write it
If firstchar = "$" Then
If fieldfound = False Then
workrecord=""
Bypass=True
Exit Sub
Else
length = Len(workrecord) - 1
Newrecord = Mid(workrecord, 2, length)
workrecord = Newrecord
bypass=False
End If
End If
Bypass=False
End Sub
Sub WriteError (msg)
shopwriteError msg
end sub
'
Private Sub FindField(fieldname, value, rc, parsearray, parsers)
Dim i
Dim temparea
Dim ucfieldname
Dim Fieldtype
'On error resume next
ucfieldname = UCase(fieldname)
rc = 0
ProcessKeyword ucfieldname, value, rc, parsearray, parseRS
If rc = 0 Then Exit Sub
rc = 0
FindInDatabase ucfieldname, temparea, fieldtype ,rc, parsearray
If rc > 0 then
WriteError "Field " & fieldname & " " & getlang("LangDatabaseFail")
value=""
exit sub
end if
If temparea="" then
value=""
exit sub
end if
' debugwrite fieldname & " type=" & fieldtype & " " & temparea
DoSpecialFormating temparea, Parsearray, parseRS
value = temparea
End Sub
'
Sub FindInDatabase (fieldname, fieldvalue, fieldtype, rc, parsearray)
dim i
dim fieldcount, fieldvalues, fieldtypes, fieldnames
fieldcount=parsearray(pfieldcount)
fieldnames=parsearray(pfieldnames)
fieldvalues=parsearray(pfieldvalues)
fieldtypes=parsearray(pfieldtypes)
'Debugwrite "finding=" & fieldname & " fieldcount=" & fieldcount
for i=0 to fieldcount
' debugwrite "field=" & fieldnames(i) & " value=" & fieldvalues(i)
if fieldname=Fieldnames(i) then
fieldvalue=fieldvalues(i)
fieldtype=fieldtypes(i)
rc=0
'debugwrite fieldname & " found =" & fieldvalue
exit sub
end if
next
rc=4
fieldvalue=""
end sub
'
Sub ProcessKeyword (keyword, value, rc, parsearray,parseRS)
dim tokenformat
tokenformat=parsearray(ptokenformat)
rc=4
Select Case keyword
Case "ADD_OITEMS"
Handle_OITEMS value, parsearray,parseRS
rc=0
Case "ADD_PAGEHEADER"
Handle_PAGEHEADER value, parsearray
rc=0
Case "ADD_PAGETRAILER"
Handle_PageTrailer value, parsearray
rc=0
Case "SPECIAL_ORDERBUTTON"
Handle_SpecialOrderButton value,parsearray,parseRS
rc=0
Case "SPECIAL_CHECKBOX"
Handle_SpecialCheckbox value,parsearray
rc=0
Case "ADD_FORMSTART"
Handle_FormStart "User",parsearray, "shopaddtocart.asp"
rc=0
Case "ADD_FORMEND"
Handle_FormEnd "User",parsearray
rc=0
Case "ADD_PRODUCTFEATURES"
Add_ProductFeatures "User",parsearray,"", parseRS
rc=0
Case "ADD_QUANTITY"
Add_Quantity "User",parsearray
rc=0
Case "ADD_ORDERBUTTON"
Add_Button "User",parsearray
rc=0
Case "ADD_CHECKBOX"
Add_Checkbox "User",parsearray
rc=0
Case "ADD_TABLE"
Add_Table "User",parsearray
rc=0
Case "ADD_TABLEEND"
Add_TableEnd "User",parsearray
rc=0
Case "ADD_PRODUCT"
Add_Product "User",parsearray
rc=0
Case "INCLUDE"
Handle_Include value,parsearray
rc=0
Case "ADD_CROSSSELLING"
Handle_CROSSSELLING value,parsearray, parseRS
rc=0
Case "SUB"
Handle_Product ucase(tokenformat)
rc=0
Case "ADD_OITEMSTEMPLATE"
Handle_OITEMSTEMPLATE value, parsearray, parseRS
rc=0
Case "ADD_OITEMTOTAL"
Handle_OitemTotal value, parsearray, parseRS
rc=0
Case "ADD_OITEMDELIVERY"
Handle_OitemDelivery value, parsearray, parseRS
rc=0
end select
end sub
Sub DoSpecialFormating (value, parsearray, parseRS)
dim tokenformat
tokenformat=parsearray(ptokenformat)
If tokenformat="" then exit sub
dim strprice
Select Case tokenformat
Case "FORMATCURRENCY"
value = shopformatcurrency(value,getconfig("xdecimalpoint"))
Case "DUALPRICE"
ConvertCurrency value, strPrice
value = formatnumber(strprice,getconfig("xdecimalpoint"))
Case "FORMATNUMBER"
value = formatnumber(value,getconfig("xdecimalpoint"))
Case "FORMATDATE"
value = shopdateformat(value,getconfig("xdateformat"))
Case "FORMATCUSTOMERPRICE"
value = HandleCustomerPrice(value, parsearray, parseRS)
Case "URLENCODE"
value = server.urlencode(value)
Case "FORMATSAVING"
value = HandlePriceSaving(value, parsearray,parseRS)
Case "FORMATTIME"
value = formatdatetime(value,vbshorttime)
End Select
end sub
'
Sub Handle_OITEMS (body, parsearray,parseRS)
'*******************************************************
' Template format order items
' expects myconn to be open as open connection
'********************************************************
Dim Isql, deliveryaddress, deliveryarray
dim orderid
Dim rsitems
Dim Dbc, recordid
Dim CR, itemname
recordid=parsearray(pidvalue)
If ucase(Getsess("emailformat"))="HTML" then
CR=" "
else
CR = GetMailCR
end if
'OpenOrderdb dbc
isql="select * from oitems where orderid="
If Getsess("oid")<>"" then
Orderid=GetSess("oid")
else
Orderid=recordid
end if
Body=""
ISql=Isql & Orderid
'debugwrite isql
Set rsitems=myconn.execute(Isql)
Do While Not RSItems.EOF
itemname=rsitems("itemname")
if getconfig("xdeliveryaddress")="Yes" then
deliveryaddress=rsitems("address")
If not isnull(Deliveryaddress) and Deliveryaddress<>"" then
ConvertDeliveryToArray DeliveryArray, Deliveryaddress
GetDeliveryName Itemname, DeliveryArray
end if
end if
If ucase(Getsess("emailformat"))<>"HTML" then
Itemname=RemoveHtmlFileio(itemname, CR)
end if
Body = Body & CR & Itemname & CR
Body = Body & getlang("LangProductQuantity") & ": " & RSItems("numitems") & CR
If getconfig("xDisplayPrices")<>"No" then
Body = Body & getlang("LangProductPrice") & ": " & shopformatcurrency(RSItems("unitprice"),getconfig("xdecimalpoint")) & CR
end if
RSItems.MoveNext
Loop
rsitems.close
Set rsitems=nothing
'Shopclosedatabase dbc
end sub
'
'
'
Sub ShopReadEntireFile(Filename, Outarray, Outcount, parsearary)
Dim i
Dim NewRecord
Dim fs,ts
Dim rc
outcount=0
OpenInputFile Filename, fs, ts, rc
If rc> 0 then
exit sub
end if
ReadEntireFile fs, ts, Outcount, OutArray, parsearray
CloseFile fs,ts, rc, parsearray
rc=0
end sub
Sub Handle_PageHeader (value, parsearray)
dim templatedisplay
templatedisplay=parsearray(ptemplatedisplay)
Value=""
If TemplateDisplay="No" then exit sub
ShopPageHeader
end sub
Sub Handle_PageTrailer (value, parsearray)
dim templatedisplay
templatedisplay=parsearray(ptemplatedisplay)
Value=""
If TemplateDisplay="No" then exit sub
ShopPageTrailer
end sub
'
Sub Handle_SpecialOrderButton (ivalue,parsearray,parseRS)
Handle_FormStart ivalue,parsearray,"shopaddtocart.asp"
Add_Table "", parsearray
prodindex=""
Add_ProductFeatures "",parsearray,"",parseRS
Add_Quantity "",parsearray
Add_Button "",parsearray
Add_Product "",parsearray
Add_TableEnd "",parsearray
Handle_FormEnd "",parsearray
end sub
Sub Add_Product (ivalue, parsearray)
Dim Id, fieldtype, rc
dim fieldname
fieldname="CATALOGID"
id=0
FindInDatabase fieldname, id, fieldtype ,rc, parsearray
If rc > 0 then
WriteError "Field " & fieldname & " " & getlang("LangDatabaseFail")
end if
%>
<%
end sub
'
Sub Add_Table (ivalue, parsearray)
dim tableflag
WriteForm TemplateTable
TableFlag="True"
parsearray(ptableflag)=tableflag
end sub
'
Sub Add_TableEnd (ivalue, parsearray)
dim tableflag
WriteForm ""
Tableflag=""
parsearray(ptableflag)=tableflag
End Sub
'
Sub Handle_SpecialCheckBox (ivalue, parsearray)
Handle_FormStart ivalue, "shopproductselect.asp"
Add_Table "",parsearray
Add_ProductFeatures "",parsearray, "0"
Add_Quantity "", parsearray
Add_CheckBox "",parsearray
Add_Button "",parsearray
Add_TableEnd "",parsearray
Add_ProductIndex "",parsearray
Handle_FormEnd "",parsearray
end sub
Sub Add_ProductIndex (ivalue, parsearray)
WriteForm ""
end sub
'
Sub Add_CheckBox (ivalue, parsearray)
Dim Id, fieldname,fieldtype, rc
fieldname="CATALOGID"
FindInDatabase fieldname, Id, fieldtype ,rc,parsearray
If rc > 0 then
WriteError "Field " & fieldname & " " & getlang("LangDatabaseFail")
end if
If TableFlag<>"" then
Response.write TemplateCheckboxRow & TemplateCheckboxColumn
end if
WriteForm ""
if TableFlag<>"" then
WriteForm TemplateCheckboxColumnEnd
Response.write ""
end if
end sub'
Sub Add_Button (ivalue, parsearray)
dim mytext, mybutton, tableflag
tableflag=parsearray(ptableflag)
dim fieldvalue
dim rc
Dim Id, fieldname,fieldtype
WriteNoStockMessage rc, parsearray
if rc> 0 then exit sub
fieldname="CATALOGID"
FindInDatabase fieldname, Id, fieldtype ,rc,parsearray
If rc > 0 then
WriteError "Field " & fieldname & " " & getlang("LangDatabaseFail")
else
ID=0
end if
mytext=getconfig("XButtonText")
if mytext="" then
mytext="Order"
end if
mybutton=""
fieldname="BUTTONIMAGE"
fieldvalue=""
FindInDatabase fieldname, fieldvalue, fieldtype ,rc,parsearray
if fieldvalue<>"" then
mybutton= fieldvalue
else
if getconfig("xButtonImage") <>"" then
mybutton=getconfig("xButtonImage")
end if
end if
if tableflag<>"" then
Response.write TemplateButtonRow & TemplateButtonColumn
end if
If myButton="" then
WriteForm ""
else
WriteForm ""
end if
If tableflag<>"" then
response.write ""
end if
end sub
'
Sub Add_Quantity (ivalue, parsearray)
dim strminimumquantity, rc, tableflag, fieldtype
tableflag=parsearray(ptableflag)
FindInDatabase "MINIMUMQUANTITY", strminimumquantity ,fieldtype, rc,parsearray
If strminimumquantity="" then
strminimumquantity=0
end if
If strMinimumquantity=0 then
If tableflag<>"" then
Response.write TemplateQuantityRow & TemplateQuantityColumn
end if
%>
<%
If tableflag<>"" then
response.write TemplateQuantityColumnEnd & ""
end if
else
GenerateMinimumList strMinimumquantity, parsearray
end if
End sub
'
Sub GetFieldValues (RS, fieldnames, fieldvalues, fieldtypes, fieldcount)
Dim i
dim fldname
i=0
' memo fields must be gotten first
For each fldName in RS.Fields
fieldnames(i) = ucase(fldname.name)
fieldTypes(i) = fldname.type
If Fieldtypes(i)="201" then
fieldvalues(i)=RS(i)
end if
i=i+1
next
fieldcount=i-1
for i=0 to fieldcount
if fieldtypes(i)<>"201" then
fieldvalues(i)=RS(i).value
end if
if isnull(fieldvalues(i)) then
fieldvalues(i)=""
end if
'Debugwrite fieldnames(i) & " " & fieldvalues(i)
next
End Sub
Sub ParseRecord (record,words,wordcount,delimiter)
Dim pos
Dim recordl
Dim bytex
Dim temprec
Dim maxwords
Dim i
maxwords = 10
temprec = record
Dim maxentries
pos = 1
wordcount = 0
' make sure word array is null
maxentries = UBound(words)
For i = 0 To maxentries - 1
words(i) = ""
Next
recordl = Len(temprec)
' first eliminate leading blanks
Do
bytex = Mid(temprec, pos, 1)
While bytex = " " And pos <= recordl
pos = pos + 1
bytex = Mid(temprec, pos, 1)
Wend
' copy word into word array
While bytex <> delimiter And pos <= recordl
words(wordcount) = words(wordcount) & bytex
pos = pos + 1
bytex = Mid(temprec, pos, 1)
Wend
wordcount = wordcount + 1
pos = pos + 1
If wordcount > maxentries Then Exit Sub
Loop Until pos > recordl
End Sub
'
Sub Add_ProductFeatures (ivalue, parsearray, Index,parseRS)
dim rc, fieldtype, tableflag
prodindex=index
tableflag=parsearray(ptableflag)
FindInDatabase "FEATURES", strfeatures, fieldtype, rc,parsearray
If rc=0 then
FindInDatabase "SELECTLIST", strselectlist, fieldtype, rc,parsearray
FindInDatabase "CATALOGID", lngcatalogid, fieldtype, rc, parsearray
If tableflag<>"" then
WriteForm TemplateFeaturesRow & TemplateFeaturesColumn
end if
FormatProductOptions
if tableflag<>"" then
Writeform TemplateFeaturesColumnEnd & ""
end if
end if
end sub
Sub Handle_FormStart (value, parsearray, action)
Dim Newaction
newaction="shopaddtocart.asp"
If action<>"" then
newaction=action
end if
%>
"
end sub
Sub WriteForm (text)
Response.write text
end sub
Sub Handle_Include (ivalue,parsearray)
'******************************************************
'[filename INCLUDE]
' field=abc INCLUDE]
' abc is field in recordset
'******************************************************
Dim NewRecord, ucfieldname
Dim recordObj, FsObj
dim rc
Dim MyText
dim readcount
Dim Bypass, filename, pos, fieldtype, filetype
dim values(10),valuecount
readcount=0
tokens=parsearray(ptokens)
filename=tokens(0)
pos=instr(filename,"=")
if pos>0 then
Parserecord filename,values,valuecount,"="
ucfieldname=ucase(values(1))
if ucase(values(0))="FIELD" then
FindInDatabase ucfieldname, filename, fieldtype ,rc,parsearray
If isnull(filename) or filename="" then
exit sub
end if
else
filename=values(1)
end if
end if
'debugwrite "filename=" & filename
OpenInputFile Filename, fsObj, RecordObj, rc
If rc> 0 then
shopwriteError getlang("LangReadFail") & filename
exit sub
else
GetFileType filename,filetype
end if
ReadARecord RecordObj, MyText, rc, parsearray
Do while rc=0
If filetype="TXT" then
' Response.write Server.HTMLEncode(MyText) & " "
ivalue=ivalue & Server.HTMLEncode(MyText) & " "
else
'response.write mytext
ivalue=ivalue & mytext
end if
readcount=readcount+1
ReadARecord RecordObj, MyText, rc, parsearray
Loop
CloseFile fsObj,RecordObj, rc, parsearray
end sub
'
Sub GetFileType(filename, filetype)
dim xtype
filetype="TXT"
xtype=ucase(right(filename,3))
Select case xtype
case "TXT"
filetype="TXT"
case "HTM"
filetype="HTM"
case "TML"
filetype="HTM"
end select
end sub
Sub GenerateMinimumList (strminimumquantity,parsearray)
Dim PArray(20),PArrayCount, tableflag
If Getconfig("xproductminimumquantity")="Yes" Then
If tableflag<>"" then
Response.write TemplateQuantityRow & TemplateQuantityColumn
end if
Response.write ""
If tableflag<>"" then
response.write TemplateQuantityColumnEnd & ""
end if
exit sub
end if
dim minamount, amount, multiply
tableflag=parsearray(ptableflag)
minamount=strminimumquantity
parraycount=getconfig("xproductminimumlist")
if parraycount="" then
parraycount=6
end if
parraycount=clng(parraycount)
for i = 1 to parraycount
amount=i*minamount
parray(i)=amount
next
dim i
sSelect = ""
If tableflag<>"" then
Response.write TemplateQuantityRow & TemplateQuantityColumn
end if
Response.write sSelect
If tableflag<>"" then
response.write TemplateQuantityColumnEnd & ""
end if
end sub
Function RemovehtmlFileio(itemname, CR)
dim workrecord, firstchar, morefields, pos, endpos, length
dim token
workrecord=replace(itemname," ",CR)
'If mailremovehtml<>"Yes" then
' Removehtml=workrecord
' exit function
'end if
pos=1
morefields = True
Do While morefields = True
pos=1
pos = InStr(pos, workrecord, "<")
If pos > 0 Then
endpos = InStr(pos, workrecord, ">")
If endpos=0 then
morefields=false
else
length = endpos - pos + 1
token = Mid(workrecord, pos, length)
workrecord=replace(workrecord,token,"")
end if
else
morefields=false
end if
loop
RemovehtmlFileio=workrecord
end function
'************************************************************
' add cross seelling links
'*************************************************************
Sub Handle_CrossSelling (ivalue, parsearray,parseRS)
dim lngcstock
dim strCrossProductIDs,strsql, rs, strmessage, strcdescurl,strurl
dim fieldtype,rc
FindInDatabase "CROSSSELLING", strcrossProductids, fieldtype, rc, parsearray
If rc>0 then exit sub
if strCrossProductids="" then exit sub
strsql="select * from products where catalogid in (" & strcrossproductids & ")"
strsql=strsql & " and hide=0"
if getconfig("xstocklow")<>"" then
lngcstock= clng(getconfig("xstocklow"))
strsql = strsql & " and cstock> " & lngcstock
end if
set rs=dbc.execute(strsql)
While Not rs.EOF
strCDescURL=rs("cdescurl")
If isnull(Strcdescurl) then
strCDescURL=getconfig("xCrossLinkURL")
end if
if ucase(strcDESCURL)="SHOPEXD.ASP" then
strurl="shopexd.asp?id=" & rs("catalogid")
else
strurl="shopquery.asp?catalogid=" & rs("catalogid")
end if
strMessage=strMessage & " " & Rs("cname") & ""
RS.MoveNext
WEND
RS.Close
set RS=Nothing
strMessage=" " & getlang("LangCrossSellingMessage") & strMessage
Response.write strmessage
end sub
Sub WriteNoStockMessage (rc, parsearray)
dim lngcstock,id,fieldtype,rc1, fieldname
rc=0
if getconfig("xOutOfStockLimit")="" then exit sub
fieldname="CSTOCK"
FindInDatabase fieldname, lngcstock, fieldtype ,rc1, parsearray
'debugwrite "LNGCSTOCK=" & lngcstock & " " & rc1
if isnull(lngcstock) then exit sub
If lngcstock="" then exit sub
if clng(lngcstock)>clng(getconfig("xOutOfStocklImit")) then exit sub
Response.write OutofStockColumn & getlang("LangOutOfStock") & OutofStockColumnEnd
rc=4
end sub
Sub ShopMergetemplate (dbtable, template, catalogid, idfield)
dim tempdatabase, tmprs, rc
EditOpenDatabase dbc, tempdatabase, dbtable
'on error resume next
if isnumeric (catalogid) then
Sql="select * from " & dbtable
If idfield<>"" then
sql=sql & " where " & idfield & "=" & catalogid
end if
else
sql="select * from " & dbtable
If idfield<>"" then
sql=sql & " where " & idfield & "='" & catalogid & "'"
end if
end if
Set tmpRS=dbc.execute(sql)
If tmpRS.eof then
If catalogid<>"" then
Serror = SError & getlang("LangReadFail") & "-" & getlang("LangEditTableName") & "=" & dbtable
else
Serror = SError & getlang("LangReadFail") & " " & getlang("langedittablename") & "=" & dbtable
end if
end if
If serror="" then
ShopTemplateWrite template, tmpRS, rc
end if
CloseRecordset tmpRS
Shopclosedatabase dbc
end sub
'
Function HandleCustomerPrice (iprice, parsearray,parseRS)
dim discount, categoryid, ioprice, newprice
dim fieldtype, rc
newprice=iprice
FindInDatabase "CATALOGID", catalogid, fieldtype ,rc, parsearray
FindInDatabase "CCATEGORY", categoryid, fieldtype ,rc, parsearray
ShopCustomerPrices ParseRS, catalogid, categoryid, iprice, newprice,discount
HandleCustomerprice=shopformatcurrency(newprice,getconfig("xdecimalpoint"))
end function
Function HandlePriceSAving (iprice, parsearray,parseRS)
dim discount, categoryid, ioprice, newprice
dim strretailprice, saving
dim fieldtype, rc
newprice=iprice
FindInDatabase "RETAILEPRICE", strretailprice, fieldtype ,rc, parsearray
If strretailprice="" then exit function
If strretailprice=0 then exit function
FindInDatabase "CATALOGID", catalogid, fieldtype ,rc, parsearray
FindInDatabase "CCATEGORY", categoryid, fieldtype ,rc, parsearray
ShopCustomerPrices ParseRS, catalogid, categoryid, iprice, newprice,discount
saving=strretailprice-newprice
HandlePriceSaving=shopformatcurrency(saving,getconfig("xdecimalpoint"))
end function
Sub Handle_OITEMSTEMPLATE (body, parsearray,parseRS)
'*******************************************************
' Template format order items
' expects myconn to be open as open connection
'********************************************************
dim filename, outarray(10), outcount
filename=Getconfig("xoitemstemplate")
Dim Isql,orderid, rsitems
Dim recordid
Dim CR, itemname, i
recordid=parsearray(pidvalue)
If ucase(Getsess("emailformat"))="HTML" then
CR=" "
else
CR = GetMailCR
end if
'OpenOrderdb dbc
isql="select * from oitems where orderid="
If Getsess("oid")<>"" then
Orderid=GetSess("oid")
else
Orderid=recordid
end if
Body=""
ISql=Isql & Orderid
'debugwrite isql
Set rsitems=myconn.execute(Isql)
If rsitems.eof then
closerecordset rsitems
exit sub
end if
do while not rsitems.eof
ShopTemplateArray Filename, RSITEMS, Outarray, Outcount
for i = 0 to outcount-1
itemname=outarray(i)
If ucase(Getsess("emailformat"))<>"HTML" then
Itemname=RemoveHtmlFileio(itemname, CR)
end if
Body = Body & CR & Itemname
next
rsitems.movenext
loop
closerecordset rsitems
end sub
Sub Handle_OitemTotal(value,parsearray,parseRS)
dim quantity, unitprice, rc, fieldtype, price, total
FindInDatabase "NUMITEMS", quantity, fieldtype ,rc, parsearray
FindInDatabase "UNITPRICE", unitprice, fieldtype ,rc, parsearray
Total=quantity*unitprice
value=shopformatcurrency(total,getconfig("xdecimalpoint"))
end sub
Sub Handle_OitemDelivery(value,parsearray,parseRS)
dim rc, fieldtype, price, total, itemname
dim CR
dim deliveryaddress, deliveryarray
If ucase(Getsess("emailformat"))="HTML" then
CR=" "
else
CR = GetMailCR
end if
if getconfig("xdeliveryaddress")="Yes" then
FindInDatabase "ADDRESS", deliveryaddress, fieldtype ,rc, parsearray
If not isnull(Deliveryaddress) and Deliveryaddress<>"" then
ConvertDeliveryToArray DeliveryArray, Deliveryaddress
GetDeliveryName Itemname, DeliveryArray
If ucase(Getsess("emailformat"))<>"HTML" then
Itemname=RemoveHtmlFileio(itemname, CR)
end if
value=itemname
end if
end if
end sub
'****************************************************************
' see if template is in database. If it is open the recordset
' put whole template into fsobj
'******************************************************************
Sub OpenInputFiledb (filename, fsObj, RecordObj, rc)
dim dbprefix, dbfilename, conn
shopopendatabase conn
dbprefix=left(filename,3)
if lcase(dbprefix)="db=" then
dbfilename=right(filename,len(filename)-3)
else
dbfilename=filename
end if
dim sql
sql="select * from templates where templatename='" & dbfilename & "'"
If getconfig("xdebug")="Yes" then
debugwrite sql
end if
set recordobj=conn.execute(sql)
If not recordobj.eof then
rc=0
fsobj=recordobj("template")
else
rc=4
end if
closerecordset recordobj
shopclosedatabase conn
recordobj=""
If rc=0 then
recordobj="db"
end if
end sub
Sub ReadEntireFileDB (fsoobj, RecordObj, readcount, readarray,parsearray)
dim data, delimiter, i
delimiter="~"
readcount=0
data=replace(fsoobj,vbcrlf,delimiter)
parserecord data, readarray, readcount,delimiter
'debugwrite "Recordcount=" & readcount
'for i = 0 to readcount
' debugwrite readarray(i)
'next
end sub
'***********************************************************************
' Record are already in memory in the parse arary
'************************************************************************
Sub ReadARecordDB (RecordObj, record, rc,parsearray)
dim data, currentrecord, recordcount
currentrecord=parsearray(pdatacurrentrecord)
recordcount=parsearray(pdatarecordcount)
data=parsearray(pdata)
If currentrecord=recordcount then
rc=4
exit sub
end if
record=data(currentrecord)
currentrecord=currentrecord+1
parsearray(pdatacurrentrecord)=currentrecord
rc=0
end sub
Sub CheckfileDB(filename,fieldname,rc)
dim dbprefix
dbprefix=left(filename,3)
if lcase(dbprefix)="db=" then
fieldname=right(filename,len(filename)-3)
rc=0
else
fieldname=""
rc=4
end if
end sub
%>
<%
'**********************************************************
' Subroutine to read a file
' VP-ASP 5.00
' May 17, 2003
'*********************************************************
Sub ShopReadFile (filename,ReadArray,readcount)
on error resume next
dim whichfile, rc, fsobj,recordobj
dim mytext
readcount=0
whichfile=server.mappath(filename)
set fsObj = Server.CreateObject("Scripting.FileSystemObject")
set RecordObj= fsObj.OpenTextFile(whichfile, 1, False)
If err.number > 0 then
rc=4
fsObj.close
set fsObj=nothing
exit sub
end if
ShopReadARecord RecordObj, MyText, rc
'Response.write Server.HTMLEncode(mytext) & " "
Do while rc=0
readarray(readcount)=mytext
readcount=readcount+1
shopReadARecord RecordObj, MyText, rc
' Response.write Server.HTMLEncode(mytext) & " "
Loop
set RecordObj = nothing
set fsObj = nothing
rc=0
End Sub
Sub shopReadArecord(RecordObj, record, rc)
if RecordObj.AtEndofStream then
rc=4
exit sub
end if
record = RecordObj.readline
'debugwrite server.htmlencode(record)
rc=0
end sub
Sub ShopFileExists(filename, rc)
dim fso, newfile
newfile=server.mappath(filename)
Set fso = server.CreateObject("Scripting.FileSystemObject")
If fso.FileExists(newfile) Then
rc=0
else
rc=4
end if
set fso=nothing
end sub
%>
<%
'******************************************************************
' Version 5.00
' filtering two sort fields and no display fields
' Main program logic for displaying products.
' actual formatting is done in shopproductformat or shopproductformat_withhtml
' May 20, 2003
'******************************************************************
dim search
Dim dbc
Dim PRODUCTNAME, CATALOGID
Dim ProductFields ' fields being displayed in order
Dim ProductCaptions ' Product column captions
Dim ProductFieldCount ' count of fields
Dim ProductSelect
Dim Colcount, totalcolcount
dim ProductMaxColumns, Productwithhtml
' Mod
dim yfieldnames,Sortnames, yfieldcount, sortcount
dim displayfields, displayfieldcount, displaycaptions
dim sortcaptions, yfieldcaptions
dim sortupdownnames(3),sortupdownvalues(3), sortupdowncount
dim sortfield, sortupdown, selectfield, i
dim sortfield2, sortupdown2
dim rc
' end mod
'*****************************************************
' open database and see if we are doing with html or not
' See if this is a next page request or first time
'******************************************************
shopopendatabase dbc
ProductmaxColumns=Getconfig("xproductcolumns")
ProductwithHtml=Getconfig("xProductwithhtml")
If productmaxcolumns="" then
productmaxcolumns=1
end if
productmaxcolumns=clng(productmaxcolumns)
If Productmaxcolumns>1 then
Productwithhtml="Yes"
end if
ProductSelect=getconfig("xProductSelect")
SetSess "CurrentUrl","shopdisplayproducts.asp"
mypage=request.querystring("page")
mypagesize=getconfig("xProductsPerPage")
If getconfig("xproductfiltering")="Yes" then
GetFilteringfields
SetupFiltering
end if
' If there is no page, then we must generate sql otherwise sqlis in Session(sqlQuery)
if mypage= "" then
mypage=1 ' first time through
ProcessFirst ' get input variables
CreateSql ' generate sql
else
sql=GetSess("sqlquery") ' on recursive calls we stored sql in sessikon variable
Category=GetSess("Category") ' see what previous one was
Subcat=getsess("Subcat")
cat_id=getsess("Cat_id")
' GetFilteringfields
end if
setsess "pagenumber",mypage ' for languae switch
ShopPageHeader ' normal page header
DisplayProducts ' display products
ShopPageTrailer ' normal trailer
shopclosedatabase dbc
' Process first time
Sub ProcessFirst()
CAT_ID = Request("id") ' category id
If not isnumeric(CAT_ID) then CAT_ID="" ' hacker fix
CATEGORY = Request("cat") ' category name
CleanseMessage category, rc
if rc> 0 then
category="" ' cannot trust it hacker may be trying someting
end if
SUBCAT=Request("subcat") ' subcategory id
PRODUCTNAME=Request("PRODUCT") ' product name
CleanseMessage productname, rc
if rc>0 then
productname=""
end if
CATALOGID=Request("CATALOGID") ' catalogid
SetSess "Category",CATEGORY 'remember category see what previous one was
setsess "Subcat",subcat
setsess "cat_id",cat_id
end sub
'
'*******************************************************
' product loop logic is here
' Put out headers, category image, open recordset
' SQL already exists so we simply loop through the products
'********************************************************
Sub DisplayProducts()
Dim header
Dim recordcount
dim words
dim wordcount
dim i
dim msg
dim rc, url, stayonpage
dim objrs1
Header=""
If category <> "" Then
header = header & Category
else
header= header & getlang("langProduct01")
End If
'response.write prodheaderfont & header & prodheaderfontend
ShowCategoryImage
'debugwrite sql
ShopOpenRecordSet SQL,objRS1, mypagesize, mypage
if objRS1.eof then
objRS1.Close
set objRS1=nothing
shopwriteerror getlang("langProductSearch")
exit sub
end if
recordcount=0
response.write "
"
end if
response.write("")
end if
if getconfig("xproductpagingnextprevious")="Yes" then
PageNavBarNext SQL
else
PageNavBar SQL
end if
objRS1.Close
set objRS1=nothing
If getconfig("xproductfiltering")="Yes" then
DisplayFiltering
end if
end sub
'******************************
' Sub ShowCategoryImage
' =====================
' If DisplayCategoryImages is set to Yes
' Displays the CatImage if there are not subcategories
' Display file associates with actegory
' Displays the SubCatImage if there is
'******************************
Sub ShowCategoryImage
Dim ImageFileName, description, i
Dim rs
Dim query
imagefilename=""
If cat_id="" then exit sub
If getconfig("xDisplayCategoryImages")="Yes" or getconfig("xdisplaycategoryfiles")="Yes" Then
query = "select * from categories where categoryid = " & cat_id
set rs = dbc.execute(query)
If not rs.EOF Then
imagefilename = rs("catimage")
description=rs("catextra")
if isnull(imagefilename) then
imagefilename=""
end if
if isnull(description) then
description=""
end if
end if
closerecordset rs
else
exit sub
end if
If getconfig("xDisplayCategoryImages")="Yes" and imagefilename<>"" then
response.write "
"
end if
If getconfig("xdisplaycategoryfiles")="Yes" and description <>"" then
dim readarray(500), readcount
readcount=0
ShopReadFile description,ReadArray,readcount
'debugwrite "readcount=" & readcount & " file=" & description
if readcount=0 then exit sub
response.write " "
for i = 0 to readcount-1
response.write readarray(i) & vbcrlf
next
end if
End Sub
'*****************************************************
' sql is actually created in shopproductcreatesql
' it can be complex or it could have been created by search
'*********************************************************
Sub CreateSQL
dim search
search=Request.querystring("Search")
if search<>"" then
SQL=GetSess("SQL")
setsess "sqlnofilter",sql
exit sub
end if
if getconfig("Xoldcategorymode")="Yes" then
oldProductCreateSql sql
else
ProductCreateSql sql, dbc
end if
setsess "sqlnofilter",sql
end sub
'********************************************************
' If we are doing multiple columns, fill them up
'*******************************************************
Sub FillRemainingColumns
If productmaxcolumns=1 then exit sub
If colcount=0 then exit sub
If totalcolcount"
exit sub
end if
Do While Colcount0
response.write "
"
colcount=colcount+1
loop
response.write ""
end sub
'****************************************************
' Filtering allows customers to restort displayed products
'**************************************************
Sub SetupFiltering
redim yfieldnames(50)
redim sortnames(50)
redim sortcaptions(50)
redim yfieldcaptions(50)
Getfieldnames
SetUpDown sortupdownnames,sortupdownvalues, sortupdowncount
If displayfieldcount="" then
DisplayFields=yFieldnames
Displayfieldcount=0
end if
End sub
'**************************************************
' filtering form is formatted
'***********************************************
Sub Displayfiltering
' debugwrite "In display displayfieldcount=" & displayfieldcount
response.write ""
end sub
'
Sub GetFieldnames
Dim prodfields, prodheaders, ucfield,i
sortcount=0
yfieldcount=0
SetupProductFields ProdFields, ProdHeaders
for i = 0 to ubound(prodfields)
ucfield=trim(ucase(prodfields(i)))
If ucfield<>"QUANTITY" Then
yfieldnames(yfieldcount)=prodfields(i)
yfieldcaptions(yfieldcount)=trim(prodheaders(i))
'DEbugwrite "caption=" & yfieldcaptions(yfieldcount)
yfieldcount=yfieldcount+1
If ucfield="CDESCRIPTION" then
else
sortnames(sortcount)=prodfields(i)
sortcaptions(sortcount)=prodheaders(i)
sortcount=sortcount+1
end if
end if
next
end sub
Sub SetUpDown (sortupdownnames,sortupdownvalues, sortupdowncount)
Sortupdownnames(0)="Ascending"
Sortupdownnames(1)="Decending"
Sortupdownvalues(0)="ASC"
Sortupdownvalues(1)="DESC"
SortUpDowncount=2
end sub
Sub GetFilteringFields
yFieldcount=GetSess("prodFieldcount")
yFieldnames=GetsessA("prodFieldnames")
sortfield=GetSess("prodsortfield")
sortfield2=GetSess("prodsortfield2")
sortupdown=GetSess("prodsortupdown")
DisplayFields=GetSess("prodDisplayFields")
DisplayFieldCount=GetSess("prodDisplayCount")
Displaycaptions=getsessA("Proddisplaycaptionsall")
sortfield=""
sortfield2=""
' debugwrite "sortfield=" & sortfield
' debugwrite "displayfieldcount=" & displayfieldcount
end sub
Sub GenerateSelectMULTV (iFieldnames,ifieldvalues, fieldcount,currentvalues,currentvaluecount, selectname,firstfield)
' Generates select with no values
%>
<%
end sub
'*******************************************************************************
' Get recordset for real product
'******************************************************************************
Sub GetProductRecordset (objrs1, objrs)
dim catalogid
catalogid=objrs1("catalogid")
dim sql
sql="select * from products where catalogid=" & catalogid
set objrs=dbc.execute(sql)
end sub
%>