<%
'************************************************************
' Version 6.50 Product Formatting
' Fields to be displayed are in shop$colors
' creates a table with columns
' add overallrating
' There are three variations with checkbox, without and with templates
' this routine does NOT handle templates it creates 1 row per product
' Sept 20, 2004 fix stock control and crossselling
' Sept 25, 2004 fix html formatting with inventory products
' May 30, 2005 add translate for cname, cdescription
' July 2, 2005 Inventory Product
' July 6, 2005 Crossselling now in shopproductsubs
' August 9, 2005 add inventory out of stock
'*************************************************************
dim hideprice
Dim ProdFields
Dim ProdHeaders
Dim QuantityFlag
'**************************************************************************
' format one row
'*********************************************************************
Sub ProductFormatRow
dim strinventoryproducts
dim url, stayonpage
QuantityFlag=False
hideprice = false
if getconfig("xdisplayprices") <> "Yes" then
hideprice = true
end if
if getconfig("xpriceloggedinonly") = "Yes" then
if Getsess ("login") = "" then
hideprice = true
end if
end if
If ProductSelect="Yes" then
Response.write ProdRow
ProductFormatFields
if getconfig("xproductcatalogonly")<>"Yes" then
AddSelect
end if
Response.write ""
else
'VP-ASP 6.09 - added xmysite call
response.write ""
end if
AddWebSessform
response.write ""
end if
End Sub
'*********************************************************************
' The fields being displayed are configurable in xproductfields
'*****************************************************************
Sub ProductFormatFields
Dim FieldCount
Dim i
Fieldcount=ubound(ProdFields)
if fieldcount = 0 then
shoperror getlang("langcommonno") & " " & getlang("langsearchfields") & " to " & getlang("langeditdisplay")
end if
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
Case "CNAME"
FormatName
rc=0
end Select
end sub
'
'************************************************************************
'a dda check box to the product. If it has subproducts that are being displayed
'in a table, do't add checkbox
' other subproducts allow check box
'****************************************************************************
Sub AddSelect
dim rc
if getconfig("xproductcatalogonly")="Yes" then
exit sub
end if
If productwithhtml="Yes" then
if inventorypricedisplay=false then
'exit sub
end if
end if
If inventorycheck=true then
If inventorypricedisplay=False then
addinventoryColumn
exit sub
end if
end if
PWriteNoStockMessage rc
if rc> 0 then exit sub
If productwithhtml<>"Yes" Then
response.write "
"
%>
<%
else
%>
<%
end if
End sub
'
Sub FormatName
dim productname
productname= objrs("cname")
productname=translatelanguage(dbc, "products", "cname","catalogid", lngCatalogId, productname)
Response.write ProdNameColumn & ProdNameFont
response.write productname
FormatImage
Formatoverallrating
response.write ProdNameEnd
end sub
Sub FormatDescription
Dim Fieldvalue
'Fieldvalue=objRS("cdescription")
Fieldvalue=memcdescription
fieldvalue=translatelanguage(dbc, "products", "cdescription","catalogid", lngCatalogId, fieldvalue)
response.write ProdDescriptionColumn & ProdDescriptionFont & fieldvalue
FormatProductOptions
FormatUserText
FormatSpecialOffer
'FormatCrossSelling
FormatHyperlinks
FormatComparison
Formatinventoryproducts dbc,objrs
response.write ProdDescriptionEnd
response.write ""
end sub
'
'******************************************************************************
' put out a quantity box unless using inventory products
' Inventory products cannot be purchased so put our nothing
'*****************************************************************
Sub FormatQuantity
if getconfig("xproductcatalogonly") = "Yes" then
exit sub
end if
'VP-ASP 6.5.1 - don't display this if xpriceloggedinonly = True and customer isn't logged in
if (getconfig("xpriceloggedinonly") = "Yes") AND (getsess("Login") = "") then
exit sub
end if
'VP-ASP 6.5.1 - don't display this if product is out of stock
if getconfig("xOutOfStocklImit") > "" then
if lngcstock<=clng(getconfig("xOutOfStocklImit")) then
exit sub
end if
end if
if getconfig("xstocklow") > "" then
if lngcstock<=clng(getconfig("xstocklow")) then
exit sub
end if
end if
If productwithhtml="Yes" then
if inventoryquantitydisplay=false then
' exit sub
end if
end if
If inventorycheck=true and inventoryquantitydisplay=false then
' Response.write ProdQuantityColumn
' Response.write "
"
' response.write " "
' response.write ProdQuantityEnd
'VP-ASP 6.08 - Quantity issue in inventory products
Response.write ""
QuantityFlag=True
exit sub
end if
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
if hideprice = true then exit sub
Dim OriginalPrice, decimalpoint
dim savings, displaysavings
If inventorycheck=true then
addinventoryprice
exit sub
end if
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-curcprice
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
AddCurrencyConvert curcprice
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=ShopFormatDualCurrency(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
'VP-ASP 6.09 - if breadcrumb is set to no, hide on exd page as well
if request.QueryString("bc") = "no" then
strdescurl = strdescurl & "&bc=no"
end if
end if
end if
'vpasp 6.00 - inventory -
'if layout selected is table and this is parent, don't show more info link
if not objrs.eof then
if lcase(objrs("spdisplaytype")) = "table" then
strdescurl = ""
end if
end if
'exit sub if both empty, no piont going further
If strdescurl="" and strcimageurl="" then
'VP-ASP 6.50 - show placeholder if there is no image
if getconfig("xnoimage") > "" then
GenerateImagePlaceholder
exit sub
else
exit sub
end if
end if
If strcImageUrl<>"" then
GenerateImage
else
GenerateNoImage
end if
end sub
'
'VP-ASP 6.09 - Generate Image wasn't showing more info button if there is one defined in config if there is an image for the product
Sub GenerateImage
dim productname
productname= objrs("cname")
productname=translatelanguage(dbc, "products", "cname","catalogid", lngCatalogId, productname)
dim buttonimage
buttonimage=Getconfig("xbuttonmoreinfo")
if isNull(buttonimage) Or buttonimage="" then
buttonimage=""
end if
If strDescUrl<>"" then
strDescurl=addwebsess(strdescurl)
'VP-ASP 6.09 - if showing search results, don't show breadcrumb on extended page
if request("Search") = "Yes" then
strDescurl = strDescURL & "&bc=no"
end if
If Getconfig("XextendedPopup")="Yes" then
If buttonimage="" Then
%>
<%
end if
end sub
'
Sub GenerateNoImage
dim buttonimage
strdescurl=addwebsess(strdescurl)
buttonimage=Getconfig("xbuttonmoreinfo")
if isNull(buttonimage) Or buttonimage="" then
buttonimage=""
end if
response.write "
"
'VP-ASP 6.50 - show placeholder if there is no image
if getconfig("xnoimage") > "" then
if strDescURL > "" then
If Getconfig("XextendedPopup")="Yes" then
%>" alt="<%=productname%>" /> <%
else
%>" alt="<%=productname%>" />
<%
end if
end if
end sub
'
Sub FormatButton
'******************************************************
' If product has a button image
' it is formatted here
' If a product has sub products dont add order button unless
' subproduct is formatted as a form type field (radio, dropdown)
'******************************************************
dim mybutton
Dim mytext
dim rc
if getconfig("xproductcatalogonly")="Yes" then
exit sub
end if
'VP-ASP 6.5.1 - don't display this if xpriceloggedinonly = True and customer isn't logged in
if (getconfig("xpriceloggedinonly") = "Yes") AND (getsess("Login") = "") then
exit sub
end if
If inventorycheck=True then
If inventorypricedisplay=false then
' AddInventorycolumn
exit sub
end if
end if
PWriteNoStockMessage rc
if rc> 0 then exit sub
if mytext="" then
mytext=getlang("langproductorder")
end if
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
hideprice = false
if getconfig("xdisplayprices") <> "Yes" then
hideprice = true
end if
if getconfig("xpriceloggedinonly") = "Yes" then
if Getsess ("login") = "" then
hideprice = true
end if
end if
SetupProductFields ProdFields, ProdHeaders
Fieldcount=ubound(ProdHeaders)
Response.write ProdTable
Response.write ProdHeaderRow
for i=0 to FieldCount
if getlang("langProductPrice")=ProdHeaders(i) then
If hideprice <> true Then
FormatProductHeaders ProdHeaders(i)
if getconfig("xDualPrice")="Yes" then
FormatProductHeaders getlang("langDualPrice")
end if
end if
elseif getlang("langProductQuantity")=ProdHeaders(i) then
If getconfig("xproductcatalogonly")<>"Yes" Then
formatProductHeaders ProdHeaders(i)
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
' August 9 mod to check inventory is in stock
If Inventorycheck=true then
if inventoryoutofstock=true then
If productwithhtml="Yes" then
Response.write getlang("langOutOfStock")
else
Response.write OutofStockColumn & getlang("langOutOfStock") & OutofStockColumnEnd
end if
rc=4
end if
exit sub
end if
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
' if there is use subroutine in shopproductsubs.asp to format the products
'***************************************************************
Sub FormatCrossSelling
dim lngcstock
dim headercaption
dim strCrossProductIDs,strsql
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"
'VP-ASP 600 - DON'T SHOW CHILD PRODUCTS
strsql=strsql & " AND (highercatalogid is null)"
if getconfig("xstocklow")<>"" then
lngcstock= clng(getconfig("xstocklow"))
strsql = strsql & " and cstock> " & lngcstock
end if
'VP-ASP 6.09 - only show product matching products
if getconfig("xproductmatch")="Yes" then
strsql=strsql & " and (productmatch='" & xproductmatch & "'"
strsql=strsql & " or productmatch is null)"
end if
'VP-ASP 6.09 - only show customer matching products
if getconfig("xproductmatchcustomer")="Yes" then
if GetSess("CustomerProductGroup")<>"" then
strsql=strsql & " and (customermatch like '%" & getsess("customerProductgroup") & "%'"
strsql=strsql & " or customermatch is null)"
else
strsql=strsql & " and customermatch is null"
end if
end if
Headercaption=getlang("LangCrossSellingMessage")
FormatAssociatedProducts dbc, strsql, headercaption,""
end sub
Sub FormatHyperlinks
dim strmessage, breaker, strurl
breaker=" "
If getconfig("xProductLinkTellaFriend")="Yes" then
strurl="shoptellafriend.asp?id=" & lngcatalogid
strurl=addwebsess(strurl)
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
strurl=addwebsess(strurl)
If getconfig("xbuttonwritereview")<>"" then
strmessage=breaker & ""
else
strMessage=breaker & "" & getlang("langRatingWrite") & ""
end if
breaker=" "
response.write strMessage
strurl="shopreviewlist.asp?id=" & lngcatalogid
strurl=addwebsess(strurl)
If getconfig("xbuttonreadreview")<>"" then
strmessage=breaker & ""
else
strMessage=breaker & "" & getlang("langRatingRead") & ""
end if
breaker=" "
response.write strMessage
Response.write ReviewHyperlinkFontEnd
end if
If getconfig("xProductQuestion")="Yes" then
strurl="shopquestion.asp?id=" & lngcatalogid
strurl=addwebsess(strurl)
strMessage=breaker & "" & getlang("langQuestion") & ""
Response.write ReviewHyperlinkFont
' breaker=" "
response.write strMessage
Response.write ReviewHyperlinkFontEnd
end if
If getconfig("xProductmakeanoffer")="Yes" then
strurl="shopmakeanoffer.asp?id=" & lngcatalogid
strurl=addwebsess(strurl)
strMessage=breaker & "" & getlang("langmakeanoffer") & ""
Response.write ReviewHyperlinkFont
' breaker=" "
response.write strMessage
Response.write ReviewHyperlinkFontEnd
end if
If getconfig("xProductwishlist")="Yes" then
strurl="shopwishlist.asp?action=add&id=" & lngcatalogid
strurl=addwebsess(strurl)
strMessage=breaker & "" & getlang("Langwishlistsave") & ""
Response.write ReviewHyperlinkFont
' breaker=" "
response.write strMessage
Response.write ReviewHyperlinkFontEnd
end if
end sub
Sub FormatComparison
If getconfig("xcompareproducts")="Yes" then
Response.write ReviewHyperlinkFont
response.write "" & getlang("langcompareadd") & ""
response.write " " & getlang("langcommonview") & " " & getlang("langcompareproducts") & ""
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 "
"
end sub
Sub ProductFormattrailer
end sub
Sub AddInventoryColumn
Response.write ProdButtonColumn
Response.write " "
response.write ""
end sub
Sub AddInventoryprice
response.write ProdColumnPrice & " "
Response.write ProdPriceEnd
if getconfig("xDualPrice") = "Yes" then
response.write ProdColumnPrice & " "
Response.write ProdPriceEnd
end if
end sub
'*************************************************************************
' Shopconvertcurrencylink is in shopproductsubs
'************************************************************************
Sub AddCurrencyConvert (total)
If Getconfig("xproductconvertcurrency")<>"Yes" Then exit sub
dim url, cprice
cprice=shopformatnumber(total,getconfig("xdecimalpoint"))
ShopConvertCurrencyLink cprice, url
response.write " " & url
end sub
%>