<%Option Explicit%>
<%
ShopCheckAdmin "shopa_editdisplay.asp"
'*************************************************************
' Version 5.0
' add a category to the database
' Apr 21, 2003
' Nov 19, 2003 Fix responseredirect
'***************************************************************
'Modified - Added the catlanguage field for the category display pages.
' add category template
Dim CategoryCount
Dim Categories
Dim CategoryNums
Dim dbtable
Dim strcatdescription, strcatimage
Dim lnghighercategoryid,strcathassubcategory,strcatextra
Dim strcathide,strcatproductmatch,strcatcustomermatch
dim strcattemplate
dim strcatmemo
dim helpfile
helpfile="shopa_categoryhelp.htm"
'Language Modification
dim strcatlanguage
Dim YesNos(3), YesNoCount
Yesnos(0)=replace(getlang("langcommonYes")," ","")
Yesnos(1)=replace(getlang("langCommonNo")," ","")
Dim Novalue, yesvalue
Yesvalue=yesnos(0)
novalue=yesnos(1)
Yesnocount=2
'
Dim Actiontype
Dim Which, infomsg
Dim Addaction, updateaction, deleteaction
dbtable="categories"
Dim myconn
sError=""
ShopOpenDatabase myconn
Addaction=Request.form("add")
Updateaction=Request.form("update")
Deleteaction=request("delete")
If DeleteAction<>"" then
DeleteCategory
end if
which=request("which")
GetCategories
AdminPageHeader
FormatEditHelpHeader
If addaction="" and updateaction="" Then
If which<>"" then
SetSess "categoryid", which
GetExistingProduct
end if
DisplayForm
else
ProcessUserAction
end if
ShopCloseDatabase myconn
AdminPageTrailer
SUB ProcessUserAction
GetFormData ' get fields from form
ValidateData ' make sure we have them all
if sError = "" Then
UpdateProduct
Serror=Infomsg
GetExistingProduct
which=getSess("categoryid")
end if
Displayform
end sub
Sub GetFormData
dim objrs
CatGetFieldRequest objrs,strcatmemo,"catmemo"
CatGetFieldRequest objrs,lngcategoryid,"categoryid"
CatGetFieldRequest objrs,strcatdescription,"catdescription"
CatGetFieldRequest objrs,strcatimage,"catimage"
CatGetFieldRequest objrs,lnghighercategoryid,"highercategoryid"
CatGetFieldRequest objrs,strcathassubcategory,"hassubcategory"
If strcathassubcategory=Novalue then
strcathassubcategory=""
end if
CatGetFieldRequest objrs,strcatextra,"catextra"
CatGetFieldRequest objrs,strcathide,"cathide"
If strcathide=Novalue then
strcathide=""
end if
CatGetFieldRequest objrs,strcatproductmatch,"productmatch"
CatGetFieldRequest objrs,strcatcustomermatch,"customermatch"
CatGetFieldRequest objrs,strcatlanguage,"catlanguage"
CatGetFieldRequest objrs,strcattemplate,"catproducttemplate"
end sub
'
Sub ValidateData
sError=""
If strcatdescription = "" Then
sError = sError & getlang("LangProductDescription") & " " & getlang("langcustrequired") & " "
end if
If lnghighercategoryid=getlang("LangCommonSelect") Then
lnghighercategoryid=0
End If
end sub
' ************************
Sub UpdateProduct
If getconfig("xMysql")="Yes" then
Mysqlupdatecategory myconn
exit sub
end if
dim sqlo
dim rso
dim filtersql
Set objRS = Server.CreateObject("ADODB.Recordset")
If updateaction<>"" then
filtersql ="select * from categories Where categoryid=" & GetSess("CategoryID")
' debugwrite filtersql
objRS.open filtersql, myconn, adOpenKeyset, adLockOptimistic
objRS.Update
infomsg= strcatdescription & getlang("LangProductUpdated") & " - " & GetSess("CategoryID") & " "
else
objRS.open "categories", myconn, adOpenKeyset, adLockOptimistic
objRS.AddNew
end if
'CatUpdateField objrs,lngcategoryid,"categoryid"
CatUpdateField objrs,strcatdescription,"catdescription"
CatUpdateField objrs,strcatimage,"catimage"
CatUpdateField objrs,lnghighercategoryid,"highercategoryid"
if strcathassubcategory=novalue then
strcathassubcategory=""
end if
if strcathide=novalue then
strcathide=""
end if
CatUpdateField objrs,strcathassubcategory,"hassubcategory"
CatUpdateField objrs,strcatextra,"catextra"
CatUpdateField objrs,strcathide,"cathide"
CatUpdateField objrs,strcatproductmatch,"productmatch"
CatUpdateField objrs,strcatcustomermatch,"customermatch"
CatUpdateField objrs,strcatmemo,"catmemo"
CatUpdateField objrs,strcatlanguage,"catlanguage"
CatUpdateField objrs,strcattemplate,"catproducttemplate"
objRS.Update
Closerecordset objrs
If addaction<>"" then
sqlo = "SELECT max(categoryid) FROM categories"
Set rso = myconn.Execute(sqlo)
lngcategoryID = Cint(rso(0))
Setsess "categoryID",rso(0)
which=rso(0)
rso.Close
set rso=nothing
Infomsg= strcatdescription & getlang("LangProductAdded") & " - " & GetSess("categoryID") & " "
end if
End Sub
'
Sub CatUpdateField (objrs, fieldvalue, fieldname)
if getconfig("xdebug")="Yes" then
debugwrite fieldname & "=" & fieldvalue
else
on error resume next
end if
if fieldvalue="" then
objRS(Fieldname)=NULL
exit sub
end if
'Debugwrite fieldname & "value=" & fieldvalue
if ucase(fieldvalue)="NULL" then
objRS(Fieldname)=NULL
else
objRS(Fieldname)=fieldvalue
end if
end sub
Sub DisplayForm
shopwriteerror sError
if which<>"" then
Response.write "
"
Response.Write("")
End Sub
'***********************
Sub GetCategories
' get categories from database and store in array for quicker access
dim sql
dim rsCat
SQL = "SELECT * from categories order by catdescription"
categorycount=0
Set rsCat = myconn.Execute(SQL)
redim Categories(getconfig("xMaxCategories"))
redim CategoryNums(getconfig("xMaxCategories"))
categorycount=0
Do While NOT rscat.EOF
categories(categorycount)= rscat("catdescription") & " [" & rscat("categoryid") & "]"
categorynums(categorycount)= rscat("categoryid")
' Debugwrite categories(categorycount)
categorycount=categorycount+1
rscat.movenext
loop
rscat.close
set rscat=nothing
end sub
Sub RowHeader (Header)
Dim srowColor
srowColor="FFFFFF"
Response.Write("
" & header &"
")
end sub
'
Sub GetProductCategory
' Need to get category number from array for update
Dim CategoryName
Dim i
'locate category in category table
'debugwrite "category count=" & categorycount
for i = 0 to categorycount-1
' debugwrite "searching for " & strcategory & "matching " & categories(i)
if strcategory=categories(i) then
lngCategoryID=categorynums(i)
exit sub
end if
next
lngcCategory=0
Debugwrite "GetProductCategory Failed to find =" & strcategory
end sub
Sub GetExistingProduct
dim getsql
lngcategoryid=getsess("categoryid")
getsql="select * from categories where categoryid=" & lngcategoryid
'debugwrite getsql
Set objRS = myconn.Execute(getsql)
If objRS.EOF Then
catresetfield objrs,lngcategoryid,"categoryid"
catresetfield objrs,strcatdescription,"catdescription"
catresetfield objrs,strcatimage,"catimage"
catresetfield objrs,lnghighercategoryid,"highercategoryid"
catresetfield objrs,strcathassubcategory,"hassubcategory"
strcathassubcategory=Novalue
catresetfield objrs,strcatextra,"catextra"
catresetfield objrs,strcatlanguage,"catlanguage"
catresetfield objrs,strcathide,"cathide"
catresetfield objrs,strcatproductmatch,"productmatch"
catresetfield objrs,strcatcustomermatch,"customermatch"
catresetfield objrs,strcattemplate,"cattemplate"
CatResetField objRS, strCatMemo, "catmemo"
strcathide=novalue
Else
CatGetField objrs,strcatmemo,"catmemo"
CatGetField objrs,lngcategoryid,"categoryid"
CatGetField objrs,strcatdescription,"catdescription"
CatGetField objrs,strcatimage,"catimage"
CatGetField objrs,lnghighercategoryid,"highercategoryid"
CatGetField objrs,strcathassubcategory,"hassubcategory"
If strcathassubcategory="" then
strcathassubcategory=Novalue
else
strcathassubcategory=Yesvalue
end if
CatGetField objrs,strcatextra,"catextra"
CatGetField objrs,strcatlanguage,"catlanguage"
CatGetField objrs,strcathide,"cathide"
If strcathide="" then
strcathide=Novalue
else
strcathide=Yesvalue
end if
CatGetField objrs,strcatproductmatch,"productmatch"
CatGetField objrs,strcatcustomermatch,"customermatch"
CatGetField objrs,strcattemplate,"catproducttemplate"
End If
Closerecordset objRS
End Sub
Sub CatGetField (objrs,fieldvalue,fieldname)
'debugwrite fieldname
fieldvalue=objrs(fieldname)
If isnull(fieldvalue) then
fieldvalue=""
end if
end sub
Sub CatGetFieldRequest (unused, fieldvalue,fieldname)
fieldvalue=request(fieldname)
end sub
Sub CatResetField (unused, fieldvalue,fieldname)
fieldvalue=""
end sub
Sub Deletecategory
which=request("which")
dim sql, url
sql="delete from categories where categoryid=" & which
myconn.execute(sql)
shopclosedatabase myconn
url="shopa_editdisplay.asp?table=categories"
responseredirect url
end sub
Sub CatCreateRowImage (caption, fieldname, fieldvalue,dbfield)
dim uploadurl
dim imageurl
imageurl=""
uploadurl=""
If fieldvalue<>"" then
imageurl="" & getlang("langcommonview") & ""
end if
If Getconfig("xupload")="Yes" then
if lngcategoryid<>"" then
uploadurl="shopa_upload.asp?id=" & lngcategoryid & "&field=" & dbfield & "&table=categories&idfield=categoryid&url=" & server.urlencode("shopa_addcategory.asp")
end if
end if
Response.Write tablerow & tableColumn & caption
If imageurl<>"" then
response.write " " & imageurl
end if
If uploadurl<>"" then
Response.write " " & getlang("langupload") & ""
end if
Response.write tablecolumnend
response.write "
"
end sub
Sub PCreateRowText (caption, fieldname, fieldvalue, rows, realname)
dim url, htmlurl, linkurl
url="shopa_addcategory.asp?which=" & which
htmlurl="shopa_htmledit.asp?which=" & which & "&idfield=categoryid&table=categories&fieldname=" & realname
htmlurl=htmlurl & "&url=" & server.urlencode(url)
Linkurl="" & "HTML edit" & ""
Response.write tablerow & tablecolumn & caption
If getconfig("xhtmleditor")="Yes" then
If realname<>"" and which<>"" Then
Response.write " " & linkurl
end if
end if
response.write tablecolumnend
response.write "
"
response.write "
"
FormatEditHelp fieldname, helpfile
response.write ""
end sub
Sub AddHiddenFields
Formathiddenfield "idfield","categoryid"
Formathiddenfield "which",which
Formathiddenfield "table",dbtable
end sub
Sub FormatHiddenField (fieldname, fieldvalue)
response.write "" & vbcrlf
end sub
'******************************************************************
' used in the admin section to create a text form box
'*******************************************************************
Sub CatFormatEditRow (caption,fieldname,fieldvalue)
dim capdisplay
capdisplay=caption
if capdisplay="" then
capdisplay=fieldname
end if
Response.Write TableRow
Response.write TableColumn & capdisplay & TableColumnEnd
Response.write TableColumn & "" & vbcrlf
Response.write tableColumnEnd
FormatEditHelp fieldname, helpfile
Response.write TableRowEnd
end sub
%>