<%option explicit%>
<%
'****************************************************************
' VP-ASP Display shop categories
' displays a list of categories from Shopping Database
' Version 4.50 May 5, 2002
' Support images for each category and multiple columns per listing
' Now allows product displays or subcategory displays
' Sub hide for categories
' add template handling
'****************************************************************
'
dim colcount, ycatmaxcolumns, totalcolumncount
Dim strcatImage
dim lngcatid
'dim strcategory
dim strcathide
Dim Mylink, dbc
dim highercategoryid
dim strcatmemo, strcatextra
ShopOpenDatabase dbc
CheckDatabaseOpen dbc
ycatmaxcolumns=clng(getconfig("xcatmaxcolumns"))
'
If getconfig("xoldcategorymode")="Yes" then
OldShopCategories
else
ShopCategories
end if
ShopCloseDatabase dbc
'
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
'
' 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
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
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
'*************************************
Sub FormatCategoryTemplate(lngcatid, strcategory, objrs)
dim template, rc
template=getconfig("xcategorydisplaytemplate")
If Template="" then
Serror=LangExdNoTemplate
shoperror serror
end if
if ucase(strcathide)="YES" 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
'*************************************
Sub CategoryHeader
' displays header for categories
If highercategoryid<>0 then
Generatecategorylinks
else
response.write catHeader & LangCat01 & ""
end if
response.write ""
response.write CatTable
end sub
' ***********Format Category
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 "" & LangProductProduct & ""
Response.write " " & langSubcategories & ""
Response.write ""
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
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
'***********************************************************
' compatibility mode for previous VP-ASP Versions
'***********************************************************
Sub OldShopCategories
ycatmaxcolumns=clng(getconfig("xcatmaxcolumns"))
ShopPageHeader ' Page header for shop
OldCategoryHeader ' category header on this page
OldShowcategories ' format categories on this page
ShopPageTrailer ' shop page trailer
end sub
'
' Show Categories
Sub OldShowCategories()
Dim rs
'dim lngcatid
'dim strcategory
colcount=0
SQL="Select * from categories "
SQL=sql & " Where highercategoryid=0 order by " & Getconfig("xsortcategories")
OpenRecordSet dbc, rs, sql
While Not rs.EOF
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
OldFormatCategory lngcatid, strcategory
rs.MoveNext
Wend
if colcount> 0 then
FillRemainingcolumns
end if
response.write "
"
CloseRecordSet rs
end sub
'*************************************
Sub OldCategoryHeader
' displays header for categories
%>
<%=catHeader%><%=LangCat01%>
<%
response.write ""
response.write CatTable
end sub
' ***********Format Category
Sub OldFormatCategory (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 & "..."
Response.write "
"
response.write "" & LangProductProduct & ""
Response.write " " & langSubcategories & ""
Response.write ""
end if
If strCatImage<> "" then
OldAddImage id, Name
end if
Response.write CatColumnEnd
colcount=colcount+1
if colcount>= yCatMaxColumns then
response.write ""
colcount=0
end if
end sub
Sub OldAddImage(id, iname)
dim mylink
dim linkname
linkname=Server.URLEncode(Iname)
if strSubcategory ="" then
%>
<%
else
%>
<%
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 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 "" & LangProductProduct & ""
Response.write " " & 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
%>