<%option explicit%>
<%
'****************************************************************
' VP-ASP Display shop categories
' displays a list of categories from Shopping Database
' Version 5.00 May 28, 2003 Free Version
' Support images for each category and multiple columns per listing
' Now allows product displays or subcategory displays
' Sub hide for categories
'****************************************************************
dim colcount, ycatmaxcolumns, totalcolumncount
Dim strcatImage
dim lngcatid
'dim strcategory
dim strcathide
Dim Mylink, dbc
dim highercategoryid
dim strcatmemo, strcatextra
'**********************************************************
' main program flow
'************************************************************
setsess "currenturl","shopdisplaycategories.asp"
ShopOpenDatabase dbc
CheckDatabaseOpen dbc
ycatmaxcolumns=clng(getconfig("xcatmaxcolumns"))
ShopCategories
ShopCloseDatabase dbc
'
'*********************************************************
' Write header
' format categories
' Write trailer
'*********************************************************
Sub ShopCategories
highercategoryid=request("id")
if highercategoryid="" then
highercategoryid=0
end if
ShopPageHeader ' Page header for shop
CategoryHeader ' category header on this page
Showcategories ' format categories on this page
ShopPageTrailer ' shop page trailer
end sub
'***************************************************************
' Format all categories
' generate SQL
' loop through all categories found
'***********************************************************'
' Show Categories
Sub ShowCategories()
Dim rs
colcount=0
totalcolumncount=0
SQL="Select * from categories "
sql = Sql & " where highercategoryid=" & highercategoryid
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
Handle_selectcategoriesbylanguage
sql=sql & " order by " & Getconfig("xsortcategories")
OpenRecordSet dbc, rs, sql
While Not rs.EOF
strcatmemo=rs("catmemo")
strcatextra=rs("catextra")
lngcatid=rs("categoryid")
strcategory=rs("catdescription")
strsubcategory=rs("hassubcategory")
strcatimage=rs("catimage") ' image
strcathide=rs("cathide") ' hide field
if isnull(strcathide) then
strcathide="No"
end if
if isNull(strcatimage) then
strcatimage=""
end if
if isNULL(strsubcategory) then
strsubcategory=""
end if
If isnull(strcategory) then
strcathide="Yes"
end if
If isnull(strcatextra) then
strcatextra=""
end if
If isnull(strcatmemo) then
strcatmemo=""
end if
' No temaplte categories in demo
FormatCategory lngcatid, strcategory
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)
shopwriteheader "HTML templates are not supported in this version"
End Sub
'**************************************************
' writes out header
'******************************************************
Sub CategoryHeader
If highercategoryid<>0 then
Generatecategorylinks
else
response.write catHeader & getlang("LangCat01") & catheaderend & "
"
end if
response.write CatTable
end sub
'*************************************************************
' formats 1 category record
'************************************************************
Sub FormatCategory (id, name)
if ucase(strcathide)="YES" 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
%>
<%
else
%>
<%
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
dim highercatid, cats(10),catids(10), i
dim cathead, more, catsql, rs
dim id,name
highercatid=highercategoryid
cathead=""
More=True
i=0
Do while more=True
catsql="select * from categories where categoryid=" & highercatid
Set rs=dbc.execute(catsql)
If not rs.eof then
highercatid=rs("highercategoryid")
name=rs("catdescription")
id=rs("categoryid")
mylink="" & name & ""
cats(i)=mylink
i=i+1
if highercatid=0 then
more=false
end if
else
more=false
end if
Closerecordset rs
loop
For i = 0 to i-1
If cathead="" Then
cathead = cats(i)
else
cathead= cats(i) & subcatseparator & cathead
end if
next
response.write subcatheader & cathead & subcatheaderend
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 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
%>