<%
'************************************************************
' Version 5.00 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
' June 9, 2003
'*************************************************************
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
Case "CNAME"
FormatName
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 & objrs("cname")
FormatImage
Formatoverallrating
response.write ProdNameEnd
end sub
Sub FormatDescription
Dim Fieldvalue
'Fieldvalue=objRS("cdescription")
Fieldvalue=memcdescription
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("cname") & ""
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 "