<%Option Explicit%> <% '****************************************************************** ' Version 6.50 ' filtering two sort fields and no display fields ' Main program logic for displaying products. ' actual formatting is done in shopproductformat or shopproductformat_withhtml ' Sept 8, 2004 remove extra on stay on page logic ' July 2, 2005 Inventry products ' July 7, 2005 Also bought ' August 9, add inventoryoutofstock '****************************************************************** 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 Dim InventoryCheck, InventoryPriceDisplay, inventoryquantitydisplay, inventoryoutofstock ' 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 '****************************************************** initializesystem 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","ofrendas.asp" mypage=request.querystring("page") 'VP-ASP 6.08 Fix If not isnumeric(mypage) then shoperror "Page size must be numeric" end if mypagesize=getconfig("xProductsPerPage") if Request.QueryString("sppp") <> "" AND isnumeric(Request.QueryString("sppp")) then 'VP-ASP 6.50 - precautionary security fix if isnumeric(Request.QueryString("sppp")) then mypagesize = Request.QueryString("sppp") end if end if 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 shopopendatabaseP dbc SetupdynamicCategory dbc, cat_id WriteImpressions ShopPageHeaderDonacion ' normal page header DisplayProducts ' display products shopclosedatabase dbc ShopPageTrailerDonacion ' normal trailer ' 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 'VP-ASP 6.09 - security update category=cleanchars(category) SUBCAT=Request("subcat") ' subcategory id 'VP-ASP 6.09 - security update if not isnumeric(subcat) then subcat = "" PRODUCTNAME=Request("PRODUCT") ' product name CleanseMessage productname, rc if rc>0 then productname="" end if 'VP-ASP 6.09 - security update productname=cleanchars(productname) CATALOGID=Request("CATALOGID") ' catalogid If not isnumeric(CATALOGID) then CATALOGID="" ' hacker fix SetSess "Category",CATEGORY 'remember category see what previous one was setsess "Subcat",subcat setsess "cat_id",cat_id setsess "displaytemplate","" ' no default template from request 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") header="" End If GenerateCategoryLinks header 'VP-ASP 6.50 - added config option to turn breadcrumb on/off if getconfig("xbreadcrumbs") = "Yes" then response.write "
" & header & "
" end if If Category <> "" Then Response.Write "

" & Category & "

" Else Response.Write "

" & 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 "

" & smallinfofont & getlang("langCommonPage") & " " & mypage & getlang("langCommonOf") & " " & maxpages & smallinfoend & "

" If ProductSelect="Yes" then Response.Write("
") Prodindex=0 else Prodindex="" end if If ProductwithHtml<>"Yes" Then ProductFormatHeader else htmlProductFormatHeader end if While Not objRS1.EOF and recordcount < maxrecs GetProductRecordset objrs1, objrs ProductGetValues objRS, dbc ' get product values Inventorycheck=false ' no sub products InventoryPriceDisplay=true ' display prices with sub products Inventoryoutofstock=false ' there are inventory products to display InventoryProductYesNo dbc, objrs, lngcatalogid, inventorycheck, Inventorypricedisplay, Inventoryquantitydisplay, inventoryoutofstock 'debugwrite "inventory=" & inventorycheck & "price=" & Inventorypricedisplay If Productwithhtml<>"Yes" then ProductFormatRow ' actual row is formatted else htmlProductFormatRow ' actual row is formatted end if If ProductSelect="Yes" then ProdIndex=ProdIndex+1 ' For select product end if objRS1.MoveNext closerecordset objrs recordcount=recordcount+1 colcount=colcount+1 totalcolcount=totalcolcount+1 if colcount>= ProductMaxColumns and ProductMaxcolumns>1 then response.write "" colcount=0 end if Wend FillRemainingColumns response.write "" if ProductSelect="Yes" and getconfig("xproductcatalogonly") <> "Yes" then response.write "" response.write "
" shopbutton Getconfig("xbuttonorderproduct"),getlang("langProductSelectButton"),"action" response.write "

" shopbuttonreset getconfig("xbuttonreset"),getlang("langCommonReset"),"" stayonpage=getconfig("Xproductstayonpage") If stayonpage="Yes" then url="shopdisplayproducts.asp?page=" & mypage response.write "" end if 'VP-ASP 6.50 - advanced session handling Addwebsessform 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 'VP-ASP 6.50 - add alt tag to images dim categoryname 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") 'VP-ASP 6.50 - add alt tag to images categoryname = rs("catdescription") 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 'VP-ASP 6.50 - add alt tag to images 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 "
" Response.write Productfilteringtable Response.write productfilteringrow Response.write productfilteringcolumn & getlang("langEditSort") & Productfilteringcolumnend Response.write productfilteringcolumn & getlang("langEditSort") & " 2" & Productfilteringcolumnend Response.write productfilteringcolumn & getlang("langEditDisplay") & Productfilteringcolumnend Response.write "" Response.write productfilteringrow Response.write ProductFilteringColumn response.write " " generateSelectV sortcaptions,sortnames,sortfield,"sortfield", sortcount, getlang("langCommonSelect") Response.write "

 " GenerateSelectV Sortupdownnames,Sortupdownvalues,sortupdown,"sortupdown", sortupdowncount,"" response.write Productfilteringcolumnend Response.write ProductFilteringColumn response.write " " GenerateSelectV sortcaptions,sortnames,sortfield2,"sortfield2", sortcount, getlang("langCommonSelect") response.write "

 " GenerateSelectV Sortupdownnames,Sortupdownvalues,sortupdown2,"sortupdown2", sortupdowncount,"" response.write Productfilteringcolumnend Response.write ProductFilteringColumn GenerateSelectV yfieldcaptions,yfieldnames,SelectField,"SelectField", yfieldcount, getlang("langCommonSelect") response.write "
" Response.write "" response.write Productfilteringcolumnend response.write "" Response.write productfilteringrow Response.write ProductFilteringColumn response.write Productfilteringcolumnend Response.write ProductFilteringColumn If getconfig("Xbuttonreset")="" then Response.Write("") else Response.Write("") end if response.write Productfilteringcolumnend Response.write ProductFilteringColumn shopbutton getconfig("xbuttoncontinue"),getlang("langCommonContinue"),"action" response.write Productfilteringcolumnend Response.write "" response.write "" 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 '************************************************************************ ' generate category links '************************************************************************* Sub GenerateCategoryLinks (header) 'VP-ASP 6.09 - added breadcrumb if cat_id="" then if request("bc") <> "no" and lcase(request("search")) <> "yes" then 'VP-ASP 6.50 - added config option to turn breadcrumb on/off if getconfig("xbreadcrumbs") = "Yes" then 'VP-ASP 6.50 - advanced session handling response.write "
" & getlang("langcommonhome") & " " & SubCatSeparator & "" & getlang("LangCommonCategories") & "" & subcatseparator & getlang("langproductproduct") & "
" end if elseif lcase(request("search")) = "yes" Then response.write "
" & getlang("langcommonhome") & " " & SubCatSeparator & getlang("langcommonsearch") & "
" end if exit sub end if If getconfig("xproductcategorylinks")<>"Yes" then exit sub dim highercatid, cats(10),catids(10), i, mylink, categoryid dim cathead, more, catsql, rs dim id,name cathead="" More=True i=0 highercatid=cat_id Do while more=True catsql="select * from categories where categoryid=" & highercatid set rs = dbc.execute(catsql) If not rs.eof then highercatid=rs("highercategoryid") categoryid=rs("categoryid") name=rs("catdescription") id=rs("categoryid") name=translatelanguage(dbc, "categories", "catdescription","categoryid", categoryid, name) 'VP-ASP 6.50 - advanced session handling if i=0 then 'mylink=name mylink="" & name & "" else mylink="" & name & "" end if cats(i)=mylink i=i+1 if highercatid=0 then more=false end if else more=false end if closerecordset rs loop 'VP-ASP 6.09 - added breadcrumb 'VP-ASP 6.50 - advanced session handling mylink="" & getlang("langcommonhome") & " " & SubCatSeparator & "" & getlang("LangCommonCategories") & "" cats(i)=mylink i=i+1 For i = 0 to i-1 If cathead="" Then cathead = cats(i) else cathead= cats(i) & subcatseparator & cathead end if next header=cathead setsess "breadcrumb", cathead end sub Sub WriteImpressions if CAT_ID <> "" then 'increment category impressions dbc.execute("UPDATE categories SET impressions = impressions + 1 WHERE categoryid = " & CAT_ID) End If End Sub %>