<%option explicit%> <% '**************************************************************** ' VP-ASP Display shop categories ' displays a list of categories from Shopping Database ' Version 6.50 ' Support images for each category and multiple columns per listing ' Now allows product displays or subcategory displays ' Sub hide for categories ' add template handling ' July 5, 2004 ' April 26, 2005 ad translate facility ' Dec 31, 2005 put back 6.50 category template formatting '**************************************************************** dim colcount, ycatmaxcolumns, totalcolumncount Dim strcatImage dim lngcatid 'dim strcategory dim strcathide Dim Mylink, dbc dim highercategoryid dim strcatmemo, strcatextra,strcatproducttemplate '********************************************************** ' main program flow '************************************************************ setsess "currenturl","shopdisplaycategories.asp" highercategoryid=request("id") If not isnumeric(highercategoryid) then highercategoryid="" end if if highercategoryid="" then highercategoryid=0 end if InitializeSystem ShopOpenDatabaseP dbc CheckDatabaseOpen dbc ycatmaxcolumns=clng(getconfig("xcatmaxcolumns")) SetupdynamicCategory dbc, highercategoryid ShopPageHeader ' Page header for shop CategoryHeader ' category header on this page Showcategories ' format categories on this page ShopCloseDatabase dbc ShopPageTrailer ' shop page trailer '*************************************************************** ' Format all categories ' generate SQL ' loop through all categories found '***********************************************************' ' Show Categories Sub ShowCategories() Dim rs dim categoryid colcount=0 totalcolumncount=0 SQL="Select * from categories " sql = Sql & " where highercategoryid=" & highercategoryid if getconfig("xproductmatch")="Yes" then 'VP-ASP 6.50 - enhanced product matching 'sql=sql & " and (productmatch='" & xproductmatch & "' or productmatch='' or productmatch is null)" sql=sql & " and " generateProductmatchsqlsubscat sql ' in shopproductsubs end if '*********************************************************** ' VPASP 600 ' Use customer matching in same was as shopdisplayproducts.asp '***********************************************************' if getconfig("xproductmatchcustomer")="Yes" then if GetSess("CustomerProductGroup")<>"" then sql=sql & " and (customermatch like '%" & getsess("customerProductgroup") & "%'" sql=sql & " or customermatch is null)" else sql=sql & " and customermatch is null" end if end if '***********************************************************' Handle_selectcategoriesbylanguage sql=sql & " order by " & Getconfig("xsortcategories") OpenRecordSet dbc, rs, sql While Not rs.EOF categoryid=rs("categoryid") strcatmemo=rs("catmemo") strcatextra=rs("catextra") lngcatid=rs("categoryid") strcategory=rs("catdescription") strsubcategory=rs("hassubcategory") strcatimage=rs("catimage") ' image strcathide=rs("cathide") ' hide field strcatproducttemplate = rs("catproducttemplate") if isnull(strcathide) then 'VP-ASP 6.09 - change to use lang variable strcathide=trim(lcase(getlang("langcommonno"))) end if if isNull(strcatimage) then strcatimage="" end if if isNULL(strsubcategory) then strsubcategory="" end if If isnull(strcategory) then 'VP-ASP 6.09 - change to use lang variable strcathide=trim(getlang("langcommonyes")) else strcategory=translatelanguage(dbc, "categories", "catdescription","categoryid", categoryid, strcategory) end if If isnull(strcatextra) then strcatextra="" end if If isnull(strcatmemo) then strcatmemo="" end if If getconfig("xcategoryusetemplate")= "Yes" then FormatCategoryTemplate lngcatid, strcategory,rs else FormatCategory lngcatid, strcategory End if rs.MoveNext Wend if colcount> 0 then FillRemainingcolumns end if response.write "" CloseRecordSet rs end sub '************************************* ' Used only if template formatting is used '************************************************* Sub FormatCategoryTemplate(lngcatid, strcategory, objrs) dim template, rc template=getconfig("xcategorydisplaytemplate") If Template="" then Serror=getlang("LangExdNoTemplate") shoperror serror end if 'VP-ASP 6.09 - change to use lang variable if ucase(strcathide)=ucase(trim(getlang("langcommonyes"))) then exit sub end if if colcount=0 then Response.write CatRow end if response.write CatColumn ShopTemplateWrite template, objRs, rc Response.write CatColumnEnd colcount=colcount+1 totalcolumncount=totalcolumncount+1 if colcount>= yCatMaxColumns then response.write "" colcount=0 end if End Sub '************************************************** ' writes out header '****************************************************** Sub CategoryHeader dim header If highercategoryid<>0 then Generatecategorylinks header else 'VP-ASP 6.09 - added breadcrumb / VP-ASP 6.50 - added config option to turn breadcrumb on/off if getconfig("xbreadcrumbs") = "Yes" then response.write "
" & getlang("langcommonhome") & " " & SubCatSeparator & getlang("LangCommonCategories") & "
" end if response.write "

" & getlang("LangCat01") & "

" end if 'VP-ASP 6.50 - show category file/image if displaying sub-categories if highercategoryid > "" then ShowCategoryImage end if response.write CatTable end sub '************************************************************* ' formats 1 category record '************************************************************ Sub FormatCategory (id, name) 'VP-ASP 6.09 - change to use lang variable if ucase(strcathide)=ucase(trim(getlang("langcommonyes"))) then exit sub end if if colcount=0 then Response.write CatRow end if response.write CatColumn if strSubcategory ="" then response.write "" & name & "" else Response.write "" & name & "..." If getconfig("Xcategoryproductsonly")="No" then Response.write "
" response.write "" & getlang("LangProductProduct") & "" Response.write " " & getlang("langSubcategories") & "" end if end if If strCatImage<> "" then AddImage id, Name end if If strcatmemo<>"" then FormatCatmemo end if Response.write CatColumnEnd colcount=colcount+1 totalcolumncount=totalcolumncount+1 if colcount>= yCatMaxColumns then response.write "" colcount=0 end if end sub '*************************************************************** ' if category has image, format it '*************************************************************** Sub AddImage(id, iname) dim mylink dim linkname linkname=Server.URLEncode(Iname) if strSubcategory ="" then %>

<%=strcategory%>

<% else %>

<%=strcategory%>

<% end if end sub Sub FillRemainingColumns If totalcolumncount< ycatmaxcolumns then response.write "" exit sub end if Do While Colcount " colcount=colcount+1 loop response.write "" end sub ' Sub GenerateCategoryLinks (header) dim highercatid, cats(10),catids(10), i, mylink, categoryid dim cathead, more, catsql, rs dim id,name cathead="" More=True i=0 highercatid=highercategoryid 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") ' translate id=rs("categoryid") name=translatelanguage(dbc, "categories", "catdescription","categoryid", categoryid, name) ' if i=0 then ' 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 home to breadcrumb 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 'VP-ASP 6.50 - added config option to turn breadcrumb on/off if getconfig("xbreadcrumbs") = "Yes" then response.write "
" & header & "
" end if end sub Sub Handle_Product (isub) select case isub Case "FORMATIMAGE" If strCatImage<> "" then AddImage lngcatid, strcategory end if Case "FORMATHYPERLINKS" GenerateCatLink lngcatid,strcategory Case "ADDNUMBERSUBCATS" Handle_NumberSubCats lngcatid,"","" case else debugwrite "Unknown sub" end select end sub Sub GenerateCatLink(id,name) if strSubcategory ="" then response.write "" & name & "" else Response.write "" & name & "..." If getconfig("Xcategoryproductsonly")="No" then Response.write "
" response.write "" & getlang("LangProductProduct") & "" Response.write " " & getlang("langSubcategories") & "" end if end if End Sub sub Formatcatmemo If getconfig("xcategorydisplaytext")="Yes" then if strcatmemo<>"" then response.write catmemostart & strcatmemo & catmemoend end if end if end sub sub Handle_selectcategoriesbylanguage If getconfig("xselectproductsbylanguage")="Yes" and getsess("language")<>"" then sql=sql & " and (catlanguage='" & getsess("language") & "'" sql=sql & " or catlanguage is null)" end if end sub 'VP-ASP 6.5 - show category image or file at the top of subcat display Sub ShowCategoryImage Dim ImageFileName, description, i Dim rs Dim query imagefilename="" If highercategoryid="" then exit sub If getconfig("xDisplayCategoryImages")="Yes" or getconfig("xdisplaycategoryfiles")="Yes" Then query = "select * from categories where categoryid = " & highercategoryid 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 %>