<%
ShopCheckAdmin "shopa_editdisplay.asp"
'*************************************************************
' Version 4.50 Adds a product to database
' May 23,2002
' add other fields, multi categories
' Add image upload
'***************************************************************
Dim FeatureCount
Dim Level3values,level3count
Dim Level4values,level4count
Dim Level5values,level5count
dim prodlevel3, prodlevel4,prodlevel5
dim prodlevel3count, prodlevel4count, prodlevel5count
dim strlevel4x, strlevel5x, strlevel3x
dim strcategorylist, strsubcategorylist
Dim Features
Dim dbtable
Dim Actiontype
Dim Which
Dim arrFeatures
Dim sAction
Dim Cselect
dim NoSubcategories
Dim Productvalues,Productfieldcount
Dim CurrentCategories(50), currentcategorycount
Dim CurrentSubCategories(50), currentsubcategorycount
cSelect=LangCommonSelect
NoSubcategories=LangNoSubcategories
GetTable
Dim myconn
sError=""
SetSess "CurrentURL","shopa_addproductcompat.asp"
ShopOpenDatabase myconn
GetFeatures
GetSubSubCategories
ResetProductOtherValues
sAction=Request.form("Update")
if sAction<>"" then
sAction="FIX"
else
sAction=Request("Add")
if sAction<>"" then
sAction="ADD"
end if
end if
If sAction = "" Then
AdminPageHeader
if which<>"" then ' being called to update record
GetExistingProduct
end if
DisplayForm
AdminPageTrailer
Else
actiontype=sAction
GetFormData
ValidateData()
AdminPageHeader
if sError = "" Then
UpdateProduct
if ActionType="ADD" then
serror= "Product " & strcname & LangProductAdded & " catalogid=" & GetSess("Productid") & " "
else
sError= "Product " & strcname & LangProductUpdated & "catalogid=" & GetSess("Productid") & " "
end if
GetExistingProduct
end if
DisplayForm
AdminPageTrailer
end if
ShopClosedatabase myconn
Sub GetTable
database=request.querystring("database")
dbtable = request.querystring("table")
if dbtable="" then
dbtable=request.form("dbtable")
end if
if dbtable="" then
dbtable="Products"
end if
if database="" then
database=request.form("database")
end if
Which=request.querystring("which")
if which<>"" then
SetSess "Productid",which
ActionType="FIX"
end if
end sub
Sub GetFormData
lngCatalogid = Request.Form("lngCatalogid")
strCcode = Request.Form("strCcode")
strCname = Request.Form("strCname")
memCdescription = Request.Form("memCdescription")
curCprice = Request.Form("curCprice")
strFeatures = Request.Form("strFeatures")
arrFeatures = Request.Form("arrFeatures")
strCimageurl = Request.Form("strCimageurl")
strButtonimage = Request.Form("strButtonimage")
datCdateavailable = Request.Form("datCdateavailable")
lngCstock = Request.Form("lngCstock")
lngCcategory = Request.Form("lngCcategory")
strWeight = Request.Form("strWeight")
strMfg = Request.Form("strMfg")
strCdescurl = Request.Form("strCdescurl")
lngSubcategoryid = Request.Form("Subcategoryid")
strRetailPrice = Request.Form("strRetailPrice")
strSpecialoffer = Request.Form("strSpecialOffer")
strAllowUserText = Request.Form("strAllowUserText")
strPother1 = Request.Form("strPother1")
strPother2 = Request.Form("strPother2")
strPother3 = Request.Form("strPother3")
strPother4 = Request.Form("strPother4")
strPother5 = Request.Form("strPother5")
strproductuserid = request.form("strproductuserid")
strtemplate = request.form("strtemplate")
memexdesc = request.form("memexdesc")
strextendedimage = request.form("strextendedimage")
strselectlist = request.form("strselectlist")
strkeywords=request.form("strkeywords")
strLevel3= Request.Form("strLevel3")
strLevel4 = Request.Form("strLevel4")
strLevel5 = Request.Form("strLevel5")
strLevel3X= Request.Form("strLevel3X")
strLevel4X = Request.Form("strLevel4X")
strLevel5X = Request.Form("strLevel5X")
strMinimumQuantity=request("strminimumquantity")
strsupplierid=request("strsupplierid")
boolhide=request("boolhide")
If Strsupplierid="" then
if Getsess("Supplierid")<>"" then
strsupplierid=getsess("Supplierid")
end if
end if
strcrossselling=request("strcrossselling")
If getconfig("xProductMultiCategories")="Yes" then
strcategorylist=request("strcategorylist")
strsubcategorylist=request("strsubcategorylist")
end if
strpoints=request("strpoints")
strpointstobuy=request("strpointstobuy")
strprice2=request("strprice2")
strprice3=request("strprice3")
GetProductOtherFields
end sub
Sub ValidateData
sError=""
if strcName="" Then
sError = sError & LangProductname & " " & LangCustRequired & " "
end if
if memCdescription="" Then
sError = sError & LangProductDescription & " " & langcustrequired & " "
end if
if curCPrice="" then
sError = sError & LangproductPrice & " " & LangCustrequired & " "
else
if Not IsNumeric(curcPrice) then
sError = sError & LangUserPriceError & " " & langproductprice & " "
end if
end if
If getconfig("XProductMultiCategories")="Yes" Then
if Request.Form("strCategoryList").Count =0 then
sError = sError & LangProductCategory & " " & LangCustrequired & " "
end if
else
If lngccAtegory=cSelect then
sError = sError & LangProductCategory & " " & LangCustrequired & " "
end if
end if
if datCdateavailable<>"" then
if Not IsDate(datCdateavailable) then
sError = sError & LangProductDateAvailable & " " & LangInvaliddate & " "
end if
end if
if lngcStock<>"" then
if Not IsNumeric(lngcStock) then
sError = sError & LangUserPriceError & " " & langproductstock & " "
end if
end if
If strlevel3=NoSubcategories then
strlevel3=""
else
if strlevel3="" then
strlevel3=strlevel3x
end if
end if
If strlevel4=NoSubcategories then
strlevel3=""
else
if strlevel4="" then
strlevel4=strlevel4x
end if
end if
If strlevel5=NoSubcategories then
strlevel5=""
else
if strlevel5="" then
strlevel5=strlevel5x
end if
end if
If LngSubcategoryid=cSelect then
lngsubcategoryid=""
end if
end sub
Sub UpdateProduct
dim sqlo
dim rso
dim filtersql
GetProductFeatures
Set objRS = Server.CreateObject("ADODB.Recordset")
If ActionType="FIX" then
filtersql ="select * from products Where catalogid=" & GetSess("productID")
objRS.open filtersql, myconn, adOpenKeyset, adLockOptimistic
objRS.Update
else
objRS.open "products", myconn, adOpenKeyset, adLockOptimistic
objRS.AddNew
end if
pupdatefield "ccode", strccode
pupdatefield "cname", strcname
pupdatefield "cdescription", memcdescription
pupdatefield "cprice", curcprice
pupdatefield "ccategory", lngccategory
pupdatefield "category", strcategory
'
pupdatefield "features", strfeatures
pupdatefield "cimageurl", strcimageurl
pupdatefield "buttonimage", strbuttonimage
pupdatefield "cdescurl", strcdescurl
'
pupdatefield "cdateavailable", datcdateavailable
pupdatefield "cstock", lngcstock
pupdatefield "weight", strweight
pupdatefield "mfg", strmfg
'
pupdatefield "pother1", strpother1
pupdatefield "pother2", strpother2
pupdatefield "pother3", strpother3
pupdatefield "pother4", strpother4
pupdatefield "pother5", strpother5
pupdatefield "subcategoryid", lngsubcategoryid
pupdatefield "specialoffer", strspecialoffer
pupdatefield "retailprice", strretailprice
pupdatefield "allowusertext", strallowusertext
pupdatefield "template", strtemplate
pupdatefield "extendeddesc", memexdesc
pupdatefield "extendedimage", strextendedimage
pupdatefield "selectlist", strselectlist
pupdatefield "keywords", strkeywords
pupdatefield "minimumquantity", strminimumquantity
pupdatefield "supplierid", strsupplierid
pupdatefield "crossselling", strcrossselling
pupdatefield "hide", boolhide
if getconfig("xallowsubsubcategories")="Yes" then
pupdatefield "level3", strlevel3
pupdatefield "level4", strlevel4
pupdatefield "level5", strlevel5
end if
pupdatefield "points", strpoints
pupdatefield "pointstobuy", strpointstobuy
pupdatefield "price2", strprice2
pupdatefield "price3", strprice3
if strproductuserid="" then
pupdatefield "userid", getsess("shopadmin") ' user that added product
else
pupdatefield "userid", strproductuserid ' user that added product
end if
UpdateProductOtherFields objrs
objrs.update
lngcatalogid=clng(objrs("catalogid"))
setsess "productid",lngcatalogid
objrs.close
set objrs=nothing
If getconfig("xProductMultiCategories")="Yes" Then
UpdateCategory lngCatalogId, strCategoryList
UpdateSubCategory lngCatalogId, strSubCategoryList
end if
end Sub
'
Sub PUpdateField (fieldname, fieldvalue)
on error resume next
if fieldvalue="" then
if ucase(fieldname)="HIDE" then
objrs(fieldname)=0
else
objRS(Fieldname)=NULL
end if
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
dim featurevaluecount
dim featurevalues
Dim sRowColor
sRowColor=getconfig("xTableRowColor")
Response.Write("
<%
end if
Response.Write(getconfig("xfont") & sError & "
")
if which="" then
Response.Write("
")
Response.Write("
")
End Sub
Sub PCreateRow (caption, fieldname, fieldvalue)
Response.Write tablerow & tableColumn & caption & tablecolumnend & "
" & tablecolumnend & ""
end sub
'********************************
Sub GetFeatures
dim sql
dim rsCat
sql = "select distinct featurenum, featurecaption from prodfeatures order by featurecaption"
featurecount=0
Set rsCat = myconn.Execute(SQL)
if not rscat.eof then
redim Features(getconfig("xMaxFeatureCaptions"))
else
featurecount=0
end if
Do While NOT rscat.EOF
features(featurecount)= rscat("featurecaption") & " [" & rscat("featurenum") & "]"
featurecount=featurecount+1
rscat.movenext
loop
rscat.close
set rscat=nothing
end sub
Sub RowHeader (Header)
Dim srowColor
srowColor="FFFFFF"
Response.Write("
" & header &"
")
end sub
'
Sub GetProductFeatures
dim tempFeatures
dim featurecount
dim featurearry
dim featurename
dim featurenum
dim i
Dim FeaturesArray
' if user typed in features use it
if strfeatures<>"" then
exit sub
end if
FeatureCount = Request("arrFeatures").Count
if Featurecount=0 then
strfeatures=""
exit sub
end if
tempFeatures=Request("arrFeatures")
FeaturesArray= Split(tempFeatures, ", ", -1, 1)
If FeaturesArray(0)="None" then
strfeatures=""
exit sub
end if
strfeatures=""
for i = 0 to featurecount-1
ParseOption FeaturesArray(i), featurename, featurenum
if strfeatures <>"" then
strfeatures = strfeatures &","
end if
strfeatures=strfeatures & featurenum
next
'debugwrite strfeatures
end sub
'
Sub ParseOption (Productoption, OptionName, OptionPrice)
' Option is in Form option [$xx.yy]
Dim spos, epos
Dim namelength
OptionPrice=0
Optionname=Productoption
const bracket= "["
const bracketend= "]"
spos = instr(1,Productoption, bracket)
if spos=0 then
exit sub
end if
Namelength=spos-1
If namelength> 0 then
Optionname= mid(ProductOption,1,namelength)
end if
spos=spos+1
epos = instr(spos,ProductOption,bracketend)
if epos=0 then
exit sub
end if
Length=epos-spos
OptionPrice=Mid(ProductOption,spos,length)
'Response.write OptionPrice
end sub
Sub GetExistingProduct
dim getsql
'on error resume next
lngcatalogid=GetSess("productid")
getsql="select * from products where catalogid=" & lngcatalogid
Set objRS = myconn.Execute(getsql)
If objRS.EOF Then
lngCatalogid = ""
strCcode = ""
strCname = ""
memCdescription = ""
curCprice = ""
strFeatures = ""
strCimageurl = ""
strButtonimage = ""
datCdateavailable = ""
lngCstock = ""
lngCcategory = ""
strCategory = ""
strWeight = ""
strMfg = ""
strCdescurl = ""
strPother1 = ""
strPother2 = ""
strPother3 = ""
lngSubcategoryID=""
Else
memcdescription = objrs("cdescription")
memexdesc = objrs("extendeddesc")
strproductuserid = objrs("userid")
if isnull(strproductuserid) then
strproductuserid=""
end if
if getsess("admintype")<>"SUPER" then
if ucase(strproductuserid) <> ucase(getsess("shopadmin")) then
objrs.close
set objrs=nothing
shopclosedatabase myconn
response.redirect "shoperror.asp?msg=" & server.urlencode (langeditselectfail)
exit sub
end if
end if
lngcatalogid = objrs("catalogid")
strccode = objrs("ccode")
strcname = objrs("cname")
curcprice = objrs("cprice")
strfeatures = objrs("features")
strcimageurl = objrs("cimageurl")
strbuttonimage = objrs("buttonimage")
datcdateavailable = objrs("cdateavailable")
lngcstock = objrs("cstock")
lngccategory = objrs("ccategory")
strcategory = objrs("category")
strweight = objrs("weight")
strmfg = objrs("mfg")
strsupplierid=objrs("supplierid")
strcrossselling=objrs("crossselling")
strcdescurl = objrs("cdescurl")
strpother1 = objrs("pother1")
strpother2 = objrs("pother2")
strpother3 = objrs("pother3")
strpother4 = objrs("pother4")
strpother5 = objrs("pother5")
setsess "productid", lngcatalogid
strspecialoffer = objrs("specialoffer")
strallowusertext = objrs("allowusertext")
strretailprice = objrs("retailprice")
strproductuserid = objrs("userid")
strtemplate = objrs("template")
strextendedimage = objrs("extendedimage")
strselectlist = objrs("selectlist")
strkeywords= objrs("keywords")
strlevel3= objrs("level3")
strlevel4 = objrs("level4")
strlevel5 = objrs("level5")
strminimumquantity = objrs("minimumquantity")
boolhide = objrs("hide")
lngsubcategoryid=objrs("subcategoryid")
if isnull(lngsubcategoryid) then
lngsubcategoryid=""
end if
strpoints=objrs("points")
strpointstobuy=objrs("pointstobuy")
strprice2=objrs("price2")
strprice3=objrs("price3")
GetProductOtherFieldsDb objrs
End If
End Sub
'objRS.close
Sub GetSubSubCategories
Getlevel "subcatlevel3", level3values,level3count, prodlevel3
Getlevel "subcatlevel4", level4values,level4count, prodlevel4
Getlevel "subcatlevel5", level5values,level5count, prodlevel5
end sub
Sub GetLevel (table, oarray, ocount, prodvalues)
dim sql
dim rsCat, cmaxsubcategories
cmaxsubcategories=getconfig("xmaxsubcategories")
SQL = "SELECT * from " & table
ocount=0
Set rsCat = myconn.Execute(SQL)
redim oarray(cMaxSubCategories)
redim prodvalues(cMaxSubCategories)
Do While NOT rscat.EOF
oarray(ocount)= rscat("subcategory")
ocount=ocount+1
rscat.movenext
loop
rscat.close
set rscat=nothing
end sub
Sub GetProductLevels(record, oarray, oarraycount)
oarraycount=0
if record="" then exit sub
if record=NoSubcategories then exit sub
ParseRecord record,oarray,oarraycount,","
end sub
'
Sub AddOtherFields
If otherfields="" then exit sub
othercount=ubound(otherfields)
dim i
for i = 0 to othercount
PCreateRow otherfields(i),otherfields(i),Othervalues(i)
next
end sub
'Add additional fields here
Function GetOtherFields
GetOtherfields=""
'GetOtherfields="abc","DEF")
end function
Sub UpdateSubCategory( lngCatalogId, Category)
dim cmd
dim sql
sql="delete from prodsubcategories where intcatalogid=" & lngcatalogid
myconn.execute(sql)
if category="" then exit sub
Category=Split(Category, ", ")
dim i
lngSubcategoryid=category(0)
If lngSubcategoryid=cselect then
lngsubcategoryid=""
end if
For i=0 to UBOUND(Category)
If Category(i)=LangCommonSelect Then
Else
sql="insert into prodsubcategories (intsubcategoryid,intcatalogid) values (" & category(i) & "," & lngcatalogid & ")"
myconn.execute(sql)
END IF
Next
If lngSubcategoryid="" then
sql="Update products set subcategoryid=NULL where catalogid=" & lngcatalogid
else
sql="Update products set subcategoryid=" & lngsubcategoryid & " where catalogid=" & lngcatalogid
end if
myconn.execute(sql)
End Sub
Sub UpdateCategory( lngCatalogId, Category)
dim cmd
dim sql
sql="delete from prodcategories where intcatalogid=" & lngcatalogid
myconn.execute(sql)
Category=Split(Category, ", ")
dim i
LngcCategory=category(0)
For i=0 to UBOUND(Category)
sql="insert into prodcategories (intcategoryid,intcatalogid) values (" & category(i) & "," & lngcatalogid & ")"
myconn.execute(sql)
Next
sql="Update products set ccategory=" & lngccategory & " where catalogid=" & lngcatalogid
myconn.execute(sql)
End Sub
Sub GetCurrentCategories (catalogId)
CurrentCategoryCount=0
dim catidRS, strsql
If not isnumeric(catalogId) then exit sub
strsql="select * from prodcategories where intcatalogid=" & clng(catalogid)
Set catidRs=myconn.execute(strsql)
do while not catidrs.eof
CurrentCategories(currentcategorycount)=catidrs("intcategoryid")
Currentcategorycount=currentcategorycount+1
catidrs.movenext
loop
catidrs.close
set catidrs=nothing
end sub
Sub GetCurrentSubCategories (catalogId)
CurrentSubCategoryCount=0
dim catidRS, strsql
If not isnumeric(catalogId) then exit sub
strsql="select * from prodsubcategories where intcatalogid=" & clng(catalogid)
Set catidRs=myconn.execute(strsql)
do while not catidrs.eof
CurrentsubCategories(currentsubcategorycount)=catidrs("intsubcategoryid")
Currentsubcategorycount=currentsubcategorycount+1
catidrs.movenext
loop
catidrs.close
set catidrs=nothing
'Debugwrite "subcatcount=" & currentsubcategorycount
end sub
Sub GenerateSelectTableMULT (table, selectname, currentvalues, currentvaluecount,FirstField, sortfield, rsfieldname, rsdisplayfield)
%>
"
exit sub
end if
end if
end if
Set genrs=myconn.execute(gensql)
' Generates Select with values
Do while not genrs.eof
rsfieldvalue=genrs(rsfieldname)
displayfieldvalue=genrs(rsdisplayfield)
If currentvaluecount> 0 then
Found="FALSE"
j=0
Do WHILE found="FALSE" and j < currentvaluecount
if rsfieldvalue= Currentvalues(j) then
currentvalue=rsfieldvalue
found="TRUE"
end if
j=j+1
Loop
end if
If currentvalue= rsfieldvalue then
response.write ""
else
response.write ""
end if
genrs.movenext
loop
response.write ""
genrs.close
set genrs=nothing
End Sub
Sub GenerateSelectTable (table, selectname, currentvalue, Firstfield, sortfield, rsfieldname, rsdisplayfield)
%>
"
exit sub
end if
end if
end if
debugwrite gensql
Set genrs=myconn.execute(gensql)
' Generates Select with values
Do while not genrs.eof
rsfieldvalue=genrs(rsfieldname)
displayfieldvalue=genrs(rsdisplayfield)
If currentvalue= rsfieldvalue then
response.write ""
else
response.write ""
end if
genrs.movenext
loop
response.write ""
genrs.close
set genrs=nothing
End Sub
Sub AddProductOtherFields
dim words(50),wordcount, captions(50), capcount,i
if getconfig("xProductOtherFields")<>"" then
Parserecord getconfig("xProductOtherFields"), words, wordcount,","
Parserecord getconfig("xProductOtherCaptions"), captions, capcount,","
for i = 0 to wordcount-1
If isarray(Productvalues) then
PCreateRow captions(i),words(i), Productvalues(i)
else
PCreateRow captions(i),words(i), ""
end if
next
end if
end sub
'
Sub GetProductOtherFields
dim words(50),wordcount,i
if getconfig("xProductOtherFields")="" then exit sub
Parserecord getconfig("xProductOtherFields"), words, wordcount,","
If not isarray(productvalues) then
redim Productvalues(wordcount)
end if
productfieldcount=wordcount
for i = 0 to wordcount-1
productvalues(i)=request(words(i))
next
End sub
'
Sub GetProductOtherFieldsDB(objrs)
dim words(50),wordcount,i
on error resume next
if getconfig("xProductOtherFields")="" then exit sub
Parserecord getconfig("xProductOtherFields"), words, wordcount,","
If not isarray(productvalues) then
redim Productvalues(wordcount)
end if
productfieldcount=wordcount
for i = 0 to wordcount-1
productvalues(i)=objrs(words(i))
if isnull(productvalues(i)) then
productvalues(i)=""
end if
next
End sub
Sub UpdateProductOtherFields (rs)
on error resume next
dim words(50),wordcount,i
if getconfig("xProductOtherFields")="" then exit sub
If not isarray(Productvalues) then exit sub
Parserecord getconfig("xProductOtherFields"), words, wordcount,","
for i = 0 to wordcount-1
If Productvalues(i)<> "" then
rs(words(i))=Productvalues(i)
else
rs(words(i))=NULL
end if
next
end sub
Sub ResetProductOtherValues
Setsess "Productvalues",""
end sub
'
Sub PCreateRowImage (caption, fieldname, fieldvalue,dbfield)
dim uploadurl
dim imageurl
imageurl=""
uploadurl=""
If fieldvalue<>"" then
imageurl="" & langcommonview & ""
end if
If Getconfig("xuploadimage")<>"Yes" then
if lngcatalogid<>"" then
uploadurl="shopa_upload.asp?id=" & lngcatalogid & "&field=" & dbfield & "&table=products&idfield=catalogid&url=" & server.urlencode("shopa_addproduct.asp")
end if
end if
Response.Write tablerow & tableColumn & caption
If imageurl<>"" then
response.write " " & imageurl
end if
If uploadurl<>"" then
Response.write " " & langupload & ""
end if
Response.write tablecolumnend
response.write "