<% ShopCheckAdmin "shopa_editdisplay.asp" '************************************************************* ' Version 6.50 Adds a product to database ' Nov 13, 2005 ' Dec 5, 2006 add generate static page '*************************************************************** dim categoryarray,categorycount ' xxx by 4 array Const dccategoryid = 0 ' categoryid Const dccatdescription = 1 ' name Const dccatlinks = 2 ' links Const dchighercategoryid = 3 ' highercategoryid const dcnote=4 const dchassubcategory = 5 Dim FeatureCount, crosssellingcount dim strcategorylist, strsubcategorylist '========================= 'VP-ASP 600 - insertion of template for shopdisplayproducts listing '14/10/2005 '========================= dim strtemplatelisting '========================= 'VP-ASP 6.09 - added featurenums Dim Features, featurenums, crossselling Dim dbtable Dim Actiontype, deleteaction, addsubaction dim staticaction Dim Which Dim arrFeatures,arrcrossselling Dim sAction Dim Cselect dim NoSubcategories Dim Productvalues,Productfieldcount Dim CurrentCategories(500), currentcategorycount Dim strbillprice,strinstallments,strinstallmenttype,strinstallmentinterval '========================= 'VP-ASP 600 - insertion of page impressions '12/10/2005 '========================= dim strimpressions '========================= '========================= 'VP-ASP 600 - insertion of date product was added '12/10/2005 '========================= dim datCdateupdated, datCdateadded '========================= Dim Yesnos(2), yesnocount dim strhighercatalogid,strHasSubProduct,strSPDisplayType Dim myconn dim helpfile dim addcategory cSelect=getlang("LangCommonSelect") NoSubcategories=getlang("LangNoSubcategories") sError="" if getsess("delError") > "" then sError = getsess("delError") setsess "delError", "" end if addcategory=request("addcategory") GetTable SetupYesnos SetSess "CurrentURL","shopa_addproduct.asp" ShopOpenDatabaseP myconn if addcategory<>"" then Performaddcategory end if GetFeatures GetCrossSelling ResetProductOtherValues sAction=Request.form("Update") Deleteaction=request("delete") AddSubAction = request("addsubs") If DeleteAction<>"" then DeleteRecord end if 'VP-ASP 6.50 - generate individual static html page staticaction=request.form("static") if staticaction<>"" then GenerateStaticPage end if If AddSubAction<>"" then AddSubAction = "" dim howmanysubs howmanysubs = request("howmany") ActionType="" if howmanysubs > "" then if not isnumeric(howmanysubs) then shoperror "Number of sub-products must be numeric" end if end if if howmanysubs = 0 then shoperror "Can't add zero sub-products" end if GetFormData ValidateData() For i = 1 to howmanysubs lngccategory = request("lngcatalogid") UpdateProduct next 'VP-ASP 6.09 - Precautionary Security Fix dim addwhich addwhich = request("which") if which > "" then If not isnumeric(which) then shoperror "Category ID must be numeric" End if end if UpdateParentProduct addwhich response.redirect "shopa_editdisplaybulk.asp?SelectValue=" & addwhich & "&SelectField=highercatalogid&table=products" end if if sAction<>"" then sAction="FIX" else sAction=Request("Add") if sAction<>"" then sAction="ADD" end if end if if addcategory<>"" then Performaddcategory end if If sAction = "" Then AdminPageHeader ' FormatEditHelpHeader if which<>"" then ' being called to update record GetExistingProduct else if strhighercatalogid<>"" then Populatefromexistingproduct ' populate fields from higher product end if end if DisplayForm gethelp AdminPageTrailer Else actiontype=sAction GetFormData ValidateData() AdminPageHeader ' FormatEditHelpHeader if sError = "" Then UpdateProduct if ActionType="ADD" then serror= "Product " & strcname & getlang("LangProductAdded") & " catalogid=" & GetSess("Productid") & "
" else sError= "Product " & strcname & getlang("LangProductUpdated") & "catalogid=" & GetSess("Productid") & "
" end if GetExistingProduct end if DisplayForm gethelp AdminPageTrailer end if ShopClosedatabase myconn '========================================================== Sub GetTable dbtable = request.querystring("table") if dbtable="" then dbtable=request.form("dbtable") end if if dbtable="" then dbtable="products" end if Which=request("which") if which<>"" then 'VP-ASP 6.09 - Precautionary Security Fix if isNumeric(which) then SetSess "Productid",which ActionType="FIX" end if 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") '========================= 'VP-ASP 600 - insertion of page impressions '12/10/2005 '========================= strImpressions = Request.Form("strImpressions") if (strimpressions = "") or (isnull(strimpressions)) then strimpressions = 0 end if '========================= 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") strfeaturedflag = Request.Form("strfeaturedflag") '6.50 strrmadays = request.form("strrmadays") '6.50 strcustomerimage = request.form("strcustomerimage") '6.50 strPother1 = Request.Form("strPother1") strPother2 = Request.Form("strPother2") strPother3 = Request.Form("strPother3") strPother4 = Request.Form("strPother4") strPother5 = Request.Form("strPother5") strlevel3 = Request.Form("strlevel3") strlevel4 = Request.Form("strlevel4") strlevel5 = Request.Form("strlevel5") strproductuserid = request.form("strproductuserid") strtemplate = request.form("strtemplate") '========================= 'VP-ASP 600 - insertion of template for shopdisplayproducts listing '14/10/2005 '========================= strtemplatelisting = request.form("strtemplatelisting") '========================= memexdesc = request.form("memexdesc") strextendedimage = request.form("strextendedimage") strselectlist = request.form("strselectlist") strkeywords=request.form("strkeywords") strMinimumQuantity=request("strminimumquantity") strsupplierid=request("strsupplierid") if not isnumeric(strsupplierid) then strsupplierid=0 end if If Strsupplierid="" then if Getsess("Supplierid")<>"" then strsupplierid=getsess("Supplierid") end if end if strcrossselling=request("strcrossselling") arrcrossselling = Request.Form("arrcrossselling") strcategorylist=request("strcategorylist") 'strsubcategorylist=request("strsubcategorylist") strclanguage=request("strclanguage") strgroupfordiscount=request("strgroupfordiscount") strattachment=request("strattachment") strdownload=request("strdownload") strcustomermatch=request("strcustomermatch") strproductmatch=request("strproductmatch") If strsubcategorylist=cselect then strsubcategorylist="" end if strpoints=request("strpoints") strpointstobuy=request("strpointstobuy") strprice2=request("strprice2") strprice3=request("strprice3") strMaximumQuantity=request("strmaximumquantity") strbillprice=request("billprice") strinstallments=request("billinstallments") strinstallmenttype=request("billinstallmenttype") strinstallmentinterval=request("billinterval") strfrontpage=request("strfrontpage") strinventoryproducts=request("strinventoryproducts") strfreeshipping=request("strfreeshipping") strtaxfree=request("strtaxfree") ' Inventory boolhide=request("boolhide") strHassubProduct = Request.Form("strHassubProduct") strSPDisplayType = Request.Form("strSPDisplayType") if strspdisplaytype=getlang("langcommonselect") then strspdisplaytype="" end if '========================= 'VP-ASP 600 - insertion of date product was added '12/10/2005 '========================= datCdateadded = Request.Form("datCdateadded") datCdateupdated = Request.Form("datCdateupdated") '========================= 'VP-ASP 6.50 - added extra image fields strImageExtra1 = Request.Form("strImageExtra1") strImageExtra2 = Request.Form("strImageExtra2") strImageExtra3 = Request.Form("strImageExtra3") strImageExtra4 = Request.Form("strImageExtra4") strImageExtra5 = Request.Form("strImageExtra5") GetProductOtherFields end sub Sub ValidateData sError="" if strcName="" Then sError = sError & getlang("LangProductname") & " " & getlang("langcustrequired") & "
" end if if memCdescription="" Then sError = sError & getlang("LangProductDescription") & " " & getlang("langcustrequired") & "
" end if if curCPrice="" then sError = sError & getlang("LangproductPrice") & " " & getlang("langcustrequired") & "
" else if Not IsNumeric(curcPrice) then 'VP-ASP 6.08 - langproductprice wasn't getlang-ed sError = sError & getlang("LangUserPriceError") & " " & getlang("langproductprice") & "
" end if end if if Request.Form("strCategoryList")=cselect then strcategorylist="" end if If lngccategory=cSelect then lngccategory="" end if if strcategorylist=cselect then strcategorylist="" end if if datCdateavailable<>"" then if Not IsDate(datCdateavailable) then sError = sError & getlang("LangProductDateAvailable") & " " & getlang("LangInvaliddate") & "
" end if end if if lngcStock<>"" then if Not IsNumeric(lngcStock) then sError = sError & getlang("LangUserPriceError") & " " & getlang("langproductstock") & "
" end if end if If LngSubcategoryid=cSelect then lngsubcategoryid="" end if if actiontype="ADD" then if lngccategory="" then lngccategory=request("maincategoryid") if lngccategory = "" then lngccategory=request("strcategorylist") end if if cstr(lngccategory) = getlang("langcommonselect") then lngccategory = "" end if if lngccategory="" then sError = sError & getlang("Langmaincategory") & " " & getlang("langcustrequired") & "
" end if end if end if end sub Sub PUpdateField (fieldname, fieldvalue) on error resume next if fieldvalue="" then objRS(Fieldname)=NULL exit sub end if if ucase(fieldvalue)="NULL" then objRS(Fieldname)=NULL else objRS(Fieldname)=fieldvalue end if end sub Sub DisplayForm dim featurevaluecount, crosssellingvaluecount dim featurevalues,crosssellingvalues Dim sRowColor sRowColor=getconfig("xTableRowColor") %>
<%shopwriteheader "Product Setup"%> <% if which<>"" then response.write "" end if response.write "" if which <> "" then response.write "" end if response.write "" %>
Advanced Edit ProductGo Back To Product List
" & getlang("langadminadvanced") & " " & getlang("LangCommonEdit") & "Back To " & ucase(left(dbtable, 1)) & right(dbtable, len(dbtable) - 1) & "
<%shopwriteerror sError%>
<% addmainproductlink ' if this product has a main product, add link back if which="" then Response.Write("
") else Response.Write("") end if 'VPASP 600 - ADD HTML EDITOR AddEditor "addproduct" 'VP-ASP 6.50 - Added buttons to top of page as well as bottom response.write "
" If lngcatalogid<>"" then 'VPASP 600 - HTMLEDITOR If getconfig("xhtmleditor")="Yes" then Response.Write("    ") Response.Write("") else Response.Write("    ") Response.Write("") end if Response.Write("  ") 'VP-ASP 6.50 - Generate individual Static HTML Files Response.Write(" ") response.write "

" else If getconfig("xhtmleditor")="Yes" then Response.Write("") else Response.Write("") end if end if response.write "

" GenerateDisplayHeader "Product Information" GenerateDisplayBodyHeader response.write "" if which<>"" or lngcatalogid<>"" then ' PCreateRowdisplay "Catalogid", "lngCatalogid", lngCatalogid end if PCreateRow getlang("LangProductName"), "strCname", strCname PCreateRow getlang("LangProductCode"),"strCcode",strcCode PCreateRowText "Short Description", "memcdescription", memcdescription,3,"cdescription" PCreateRowText "Long Description", "memexdesc", memexdesc,3,"extendeddesc" PCreateRow getlang("LangProductKeywords"),"strkeywords",strKeywords PCreateRowimage getlang("LangProductImage"),"strcimageurl",strcimageurl,"cimageurl" PCreateRowimage getlang("LangProductExtendedImage"),"strextendedimage",strExtendedImage,"extendedimage" 'VP-ASP 6.50 - added extra image fields PCreateRowimage getlang("langcommonadditionalimage") & " 1: ","strImageExtra1",strImageExtra1,"extraimage1" PCreateRowimage getlang("langcommonadditionalimage") & " 2: ","strImageExtra2",strImageExtra2,"extraimage2" PCreateRowimage getlang("langcommonadditionalimage") & " 3: ","strImageExtra3",strImageExtra3,"extraimage3" PCreateRowimage getlang("langcommonadditionalimage") & " 4: ","strImageExtra4",strImageExtra4,"extraimage4" PCreateRowimage getlang("langcommonadditionalimage") & " 5: ","strImageExtra5",strImageExtra5,"extraimage5" response.write "
" GenerateDisplayBodyFooter GenerateDisplayHeader "Pricing and Stock Control" GenerateDisplayBodyHeader response.write "" PCreateRow getlang("LangProductPrice"),"curCprice", curCprice PCreateRow getlang("LangProductPrice") & " " & 2,"strprice2",strprice2 PCreateRow getlang("LangProductPrice") & " " & 3,"strprice3",strprice3 PCreateRow getlang("LangProductRetailPrice"),"strRetailPrice",strRetailPrice PCreateRow getlang("langProductStock"),"lngCstock", lngCstock PCreateRow getlang("LangProductWeight"),"strWeight", strWeight If strtaxfree="" then strtaxfree=yesnos(1) FormateditrowBoolean getlang("LangTaxfree"),"strtaxfree",strtaxfree,yesnos,yesnocount',helpfile If strfreeshipping="" then strfreeshipping=yesnos(1) FormateditrowBoolean getlang("LangFreeShipping"),"strfreeshipping",strfreeshipping,yesnos,yesnocount',helpfile If boolhide="" then boolhide=yesnos(1) FormateditrowBoolean getlang("LangHideProduct"),"boolhide",boolhide,yesnos,yesnocount',helpfile If GetSess("Admintype")="SUPER" then 'If getconfig("xAddProductSupplierDropDown")="Yes" then Response.write tablerow & tablecolumn & getlang("LangSupplierNumber") & tablecolumnend & "") 'FormatEditHelp fieldname, helpfile response.write "" 'else 'PCreateRow getlang("LangSupplierNumber"),"strSupplierid",strsupplierid 'end if end if PCreateRow getlang("LangProductDateavailable"),"datCdateavailable",datCdateavailable response.write "
" GenerateSelectTable "suppliers","strsupplierid", strsupplierid,cSelect,"name","supplierid","name" response.write ("
" GenerateDisplayBodyFooter GenerateDisplayHeader "Categories" GenerateDisplayBodyHeader addcategories GenerateDisplayBodyFooter GenerateDisplayHeader "Product Features" GenerateDisplayBodyHeader response.write "" ''PCreateRowDisplay "Selected Features","strFeatures",strFeatures 'PCreateHiddenField "strFeatures",strFeatures 'Response.write tablerow & "") 'FormatEditHelp "strfeatures", helpfile response.write ("") PCreateRow getlang("LangProductSelectList"),"strselectlist",strSelectList response.write "
" & getlang("LangProductFeatures") & tablecolumnend 'response.write "" 'Featurevaluecount=0 'Featurevalues = split(strFeatures & ",", ",") 'Featurevaluecount=ubound(Featurevalues) 'GenerateSelectMult_NOVALUES features,featurecount, Featurevalues,Featurevaluecount,"arrFeatures", "None" if strFeatures = "0" then strFeatures = "" PCreateRow getlang("LangProductFeatureNumber"),"strFeatures",strFeatures Response.write tablerow & " " & getlang("LangProductFeatures") & tablecolumnend & vbcrlf response.write "" 'Featurevaluecount=0 'Featurevalues = split(strFeatures & ",", ",") 'Featurevaluecount=ubound(Featurevalues) GenerateFeatureSelect features,featurenums,featurecount, Featurevalues,Featurevaluecount,"arrFeatures", "- Select -" response.write "
Choose features from the box above to add them to the list of features displayed" response.write ("
" GenerateDisplayBodyFooter GenerateDisplayHeader "Cross Selling" GenerateDisplayBodyHeader response.write "" 'PCreateRow getlang("LangCrossSelling"),"strCrossSelling",strCrossSelling ' if getconfig("xcrossselling") = "Yes" then 'PCreateRowDisplay "Selected " & getLang("LangCrossSelling"),"strCrossSelling",strCrossSelling if getconfig("xproductaddsimplemode") = "Yes" then PCreateRow getlang("LangCrossSelling"),"strCrossSelling",strCrossSelling else PCreateHiddenField "strCrossSelling",strCrossSelling Response.write tablerow & "") 'FormatEditHelp "strcrossselling", helpfile response.write ("") end if ' end if response.write "
" & getlang("LangCrossSelling") & tablecolumnend response.write "" Crosssellingvaluecount=0 Crosssellingvalues = split(strCrossSelling & ",", ",") Crosssellingvaluecount=ubound(Crosssellingvalues) GenerateSelectMult_NOVALUES crossselling,Crosssellingcount, Crosssellingvalues,Crosssellingvaluecount,"arrCrossSelling", "None" response.write ("
" GenerateDisplayBodyFooter GenerateDisplayHeader getlang("LangOtherFields") GenerateDisplayBodyHeader response.write "" pcreateRowimage getlang("LangProductOrderButton"), "strButtonimage",strButtonimage,"buttonimage" 'PCreateRow getlang("LangProductSelectList"),"strselectlist",strSelectList pcreateRow getlang("LangProductManu"),"strMfg",strMfg PCreateRow getlang("LangFrontpage"),"strfrontpage",strfrontpage PCreateRow getlang("LangProductMinimumQuantity"),"strminimumquantity",strMinimumQuantity PCreateRow getlang("LangProductMaximumQuantity"),"strMaximumquantity",strMaximumQuantity '5.0 'PCreateRow getlang("LangInventory"),"strinventoryproducts",strinventoryproducts PCreateRow getlang("LangProductOther1"),"strPother1", strPother1 PCreateRow getlang("LangProductOther2"),"strPother2",strPother2 PCreateRow getlang("LangProductOther3"),"strPother3",strPother3 PCreateRow getlang("LangProductOther4"),"strPother4",strPother4 PCreateRow getlang("LangProductOther5"),"strPother5",strPother5 PCreateRow getlang("LangOtherfields") & " 3" ,"strlevel3",strlevel3 PCreateRow getlang("LangOtherfields") & " 4" ,"strlevel4",strlevel4 PCreateRow getlang("LangOtherfields") & " 5" ,"strlevel5",strlevel5 PCreateRow getlang("LangProductSpecialOffer"),"strSpecialOffer",strSpecialoffer PCreateRow getlang("LangAllowUserText"),"strAllowUserText", strAllowUserText 'VP-ASP 6.50 - flag to determine if product should appear in Featured Products listing If strFeaturedFlag="" then strFeaturedFlag=yesnos(1) FormateditrowBoolean "Include in Featured Products","strFeaturedFlag",strFeaturedFlag,yesnos,yesnocount',helpfile 'VP-ASP 6.50 - flag to determine if customer should be allowed to upload an image If strcustomerimage="" then strcustomerimage=yesnos(1) FormateditrowBoolean "Customer Upload Image","strcustomerimage",strcustomerimage,yesnos,yesnocount',helpfile 'VP-ASP 6.50 - how many days after purchase the customer is allowed to submit an RMA for this product PCreateRow "RMA allowed days","strrmadays", strrmadays response.write "
" GenerateDisplayBodyFooter GenerateDisplayHeader "Advanced Fields" GenerateDisplayBodyHeader response.write "" ' if getconfig("xendoforderattachments") = "Yes" then PCreateRow getlang("LangOrderattachment"),"strattachment",strattachment ' end if ' if ((getconfig("xendoforderhyperlinkemail") ="Yes") OR (getconfig("xendoforderhyperlinks") ="Yes")) then PCreateRow getlang("LangOrderdownload"),"strdownload",strdownload ' end if pcreaterow getlang("langproductextended"),"strcdescurl",strcdescurl PCreateRow getlang("LangProductTemplate"),"strtemplate",strtemplate '========================= 'VP-ASP 600 - insertion of template for shopdisplayproducts listing '14/10/2005 '========================= PCreateRow "Template Listing","strtemplatelisting",strtemplatelisting '========================= ' if (getconfig("xproductgroupdiscount") = "Yes") then PCreateRow getlang("LangGroupForDiscount"),"strgroupfordiscount",strgroupfordiscount ' end if ' PCreateRow getlang("LangLanguage"),"strclanguage",strclanguage ' if getconfig("xproductmatchcustomer") = "Yes" then PCreateRow getlang("LangCustomermatch"),"strcustomermatch",strcustomermatch ' end if ' if getconfig("xproductmatch") = "Yes" then PCreateRow getlang("LangProductMatch"),"strproductmatch",strproductmatch ' end if ' if getconfig("xpoints") = "Yes" then PCreateRow getlang("LangPoints"),"strpoints",strpoints ' end if ' if getconfig("xpointsredeem") = "Yes" then PCreateRow getlang("LangRedeemPoints"),"strpointstobuy",strpointstobuy ' end if If GetSess("Admintype")="SUPER" then PCreateRow getlang("LangProductUserid"),"strProductUserid",strProductUserid end if if which <> "" then '========================= 'VP-ASP 600 - insertion of page impressions '12/10/2005 '========================= PCreateRowDisplay "Impressions","strImpressions",strImpressions '========================= '========================= 'VP-ASP 600 - insertion of date product was added '12/10/2005 '========================= PCreateRowDisplay "Date Last Updated","datCdateupdated",datCdateupdated PCreateRowDisplay "Date Added","datCdateadded",datCdateadded '========================= end if response.write "
" GenerateDisplayBodyFooter ' If getconfig("xbilling")="Yes" then GenerateDisplayHeader getlang("LangBillInstallments") GenerateDisplayBodyHeader response.write "" PCreateRow getlang("LangBilling"),"billprice",strbillprice PCreateRow getlang("LangBillInstallments"),"billinstallments",strinstallments PCreateRow getlang("LangBillInstallmentType"),"billinstallmenttype",strinstallmenttype PCreateRow getlang("LangBillInterval"),"billinterval",strinstallmentinterval response.write "
" GenerateDisplayBodyFooter ' end if AddInventoryform AddProductOtherfields AddtranslateLinkMenu myconn, which, dbtable If lngcatalogid<>"" then 'VPASP 600 - HTMLEDITOR If getconfig("xhtmleditor")="Yes" then Response.Write("    ") Response.Write("") else Response.Write("    ") Response.Write("") end if 'VP-ASP 6.50 - Moved Delete button to be on same line as Add and Update Response.Write("  ") 'VP-ASP 6.50 - Generate individual Static HTML Files Response.Write(" ") response.write "

" else If getconfig("xhtmleditor")="Yes" then Response.Write("") else Response.Write("") end if end if 'PCreateHiddenField "simplemode",simplemode ' PCreateHiddenField "strhassubproduct",strhassubproduct 'PCreateHiddenField "highercatalogid",strhighercatalogid PCreateHiddenField "lngcatalogid",lngcatalogid PCreateHiddenField "maincategoryid",lngccategory PCreateHiddenField "addsubs","" Response.Write("

") End Sub Sub PCreateRow (caption, fieldname, fieldvalue) Response.Write tablerow & "" & caption & tablecolumnend 'VP-ASP 6.50.1 - names with double quotes in them weren't being rendered correctly If Not IsNull(fieldvalue) Then fieldvalue=Replace(fieldvalue,"""",""") End If response.write "" & "" 'FormatEditHelp fieldname, helpfile Response.write "" end sub Sub PHeaderRow (caption) Response.Write "" & ReportHeadColumn & "" & caption & "" & tablecolumnend response.write " " & ReportHeadColumnend response.write tablecolumn & " " & ReportHeadColumnend & ReportrowEnd end sub Sub PCreateRowImage (caption, fieldname, fieldvalue,dbfield) dim uploadurl, imageurl imageurl="" uploadurl="" If fieldvalue<>"" then imageurl="" & getlang("langcommonview") & "" end if If Getconfig("xupload")="Yes" then ' if lngcatalogid<>"" then uploadurl="shopa_uploadpop.asp?form=addproduct&formfield=" & fieldname & "&id=" & lngcatalogid & "&field=" & dbfield & "&table=products&idfield=catalogid&url=" & server.urlencode("shopa_addproduct.asp") 'end if end if Response.Write tablerow & "" & caption & tablecolumnend response.write "" If uploadurl<>"" then ' Response.write " " & getlang("langupload") & "" Response.write " " & getlang("langupload") & "" end if If imageurl<>"" then response.write " " & imageurl end if response.write "" 'FormatEditHelp fieldname, helpfile response.write "" end sub Sub GetFeatures dim sql, 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")) 'VP-ASP 6.09 -added featurenums redim Featurenums(getconfig("xMaxFeatureCaptions")) else featurecount=0 end if Do While NOT rscat.EOF 'VP-ASP 6.09 - remove commas from list display as the caused the addition of features to break 'features(featurecount)= rscat("featurecaption") & " [" & rscat("featurenum") & "]" if not isnull(rscat("featurecaption")) then features(featurecount)= replace(rscat("featurecaption"),",","|") & " [" & rscat("featurenum") & "]" 'VP-ASP 6.09 -added featurenums featurenums(featurecount) = rscat("featurenum") featurecount=featurecount+1 end if rscat.movenext loop rscat.close set rscat=nothing end sub Sub GetCrossSelling dim sql, rsCat sql = "select count(catalogid) as thecount from products" Set rsCat = myconn.Execute(SQL) if not rscat.eof then redim crossselling(rscat("thecount")) else crosssellingcount =0 end if sql = "select catalogid, cname from products order by catalogid" ' crosssellingcount=0 Set rsCat = myconn.Execute(SQL) ' if not rscat.eof then ' redim crossselling(0) ' else ' crosssellingcount=0 ' end if Do While NOT rscat.EOF ' redim preserve crossselling(ubound(crossselling) + 1) 'VP-ASP 6.09 - replace commas in product names if not isnull(rscat("cname")) then crossselling(crosssellingcount)= replace(rscat("cname"),",","|") & " [" & rscat("catalogid") & "]" crosssellingcount=crosssellingcount+1 end if 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, featurecount, featurearry, featurename, featurenum, i, 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 end sub Sub GetCrossSelling2 dim tempCrossSelling, CrossSellingcount, CrossSellingarry, CrossSellingname, CrossSellingnum, i, CrossSellingArray CrossSellingCount = Request("arrCrossSelling").Count if CrossSellingcount=0 then ' strcrossselling="" exit sub end if tempCrossSelling=Request("arrCrossSelling") CrossSellingArray= Split(tempCrossSelling, ", ", -1, 1) If CrossSellingArray(0)="None" then strCrossSelling="" exit sub end if strCrossSelling="" for i = 0 to CrossSellingcount-1 ParseOption CrossSellingArray(i), CrossSellingname, CrossSellingnum if strCrossSelling <>"" then strCrossSelling = strCrossSelling &"," end if strCrossSelling=strCrossSelling & CrossSellingnum next end sub Sub ParseOption (Productoption, OptionName, OptionPrice) ' Option is in Form option [$xx.yy] Dim spos, epos, 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) 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 = "" '========================= 'VP-ASP 600 - insertion of date product was added '12/10/2005 '========================= ' datCdateadded = "" datCdateupdated = "" '========================= lngCstock = "" lngCcategory = "" strCategory = "" strWeight = "" strMfg = "" strCdescurl = "" strPother1 = "" strPother2 = "" strPother3 = "" lngSubcategoryID="" 'VP-ASP 6.50 - added extra image fields strimageextra1 = "" strimageextra2 = "" strimageextra3 = "" strimageextra4 = "" strimageextra5 = "" Else memcdescription = objrs("cdescription") memexdesc = objrs("extendeddesc") strproductuserid = objrs("userid") '========================= 'VP-ASP 600 - insertion of page impressions '12/10/2005 '========================= strimpressions = objrs("impressions") if (strimpressions = "") or (isnull(strimpressions)) then strimpressions = 0 end if '========================= 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 shoperror getlang("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") '========================= 'VP-ASP 600 - insertion of date product was added '12/10/2005 '========================= datcdateadded = objrs("cdateadded") datcdateupdated = objrs("cdateupdated") '========================= 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") strlevel3 = objrs("level3") strlevel4 = objrs("level4") strlevel5 = objrs("level5") strspecialoffer = objrs("specialoffer") strallowusertext = objrs("allowusertext") 'VP-ASP 6.50 - flag to determine if product should appear in Featured Products listing strfeaturedflag = objrs("featuredflag") if isnull(strfeaturedflag) then strfeaturedflag=0 CorrectBooleanProgram strfeaturedflag 'VP-ASP 6.50 - flag to determine if customer should be allowed to upload an image strcustomerimage = objrs("customerimage") if isnull(strcustomerimage) then strcustomerimage=0 CorrectBooleanProgram strcustomerimage 'VP-ASP 6.50 - how many days after purchase the customer is allowed to submit an RMA for this product strrmadays = objrs("rmadays") strretailprice = objrs("retailprice") strproductuserid = objrs("userid") '========================= 'VP-ASP 600 - insertion of page impressions '12/10/2005 '========================= strimpressions = objrs("impressions") if (strimpressions = "") or (isnull(strimpressions)) then strimpressions = 0 end if '========================= strtemplate = objrs("template") '========================= 'VP-ASP 600 - insertion of template for shopdisplayproducts listing '14/10/2005 '========================= strtemplatelisting = objrs("templatelisting") '========================= strextendedimage = objrs("extendedimage") strselectlist = objrs("selectlist") strkeywords= objrs("keywords") strminimumquantity = objrs("minimumquantity") strclanguage=objrs("clanguage") strgroupfordiscount=objrs("groupfordiscount") strattachment=objrs("orderattachment") strdownload=objrs("orderdownload") strcustomermatch=objrs("customermatch") strproductmatch=objrs("productmatch") lngsubcategoryid=objrs("subcategoryid") if isnull(lngsubcategoryid) then lngsubcategoryid="" end if strpoints=objrs("points") strpointstobuy=objrs("pointstobuy") strprice2=objrs("price2") strprice3=objrs("price3") strmaximumquantity = objrs("maximumquantity") strfrontpage = objrs("frontpage") strbillprice=objrs("billprice") strinstallments=objrs("billinstallments") strinstallmenttype=objrs("billinstallmenttype") strinstallmentinterval=objrs("billinterval") strinventoryproducts=objrs("inventoryproducts") strtaxfree=objrs("taxfree") strfreeshipping=objrs("freeshipping") if isnull(strtaxfree) then strtaxfree=0 CorrectBooleanProgram strtaxfree if isnull(strfreeshipping) then strfreeshipping=0 CorrectBooleanProgram strfreeshipping strhighercatalogid=objrs("highercatalogid") if isnull(strhighercatalogid) then strhighercatalogid="" end if strHasSubProduct= objrs("hassubproduct") strSPDisplayType=objrs("spdisplaytype") boolhide = objrs("hide") 'VP-ASP 6.50 - added extra image fields strimageextra1 = objrs("extraimage1") strimageextra2 = objrs("extraimage2") strimageextra3 = objrs("extraimage3") strimageextra4 = objrs("extraimage4") strimageextra5 = objrs("extraimage5") CorrectBooleanProgram boolhide setsess "productid", lngcatalogid GetProductOtherFieldsDb objrs End If 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 UpdateCategory( lngCatalogId, Category, maincategoryid) dim cmd, ignoremain, catarray, categoryid dim sql,i If lngccategory<>"" then updatemaincategory lngcatalogid, lngccategory end if if strcategorylist<>"" then Updateothercategory lngcatalogid, strcategorylist end if If ActionType<>"FIX" then updateprodcategories request("which"), lngCatalogId end if End Sub Sub GetCurrentCategories (catalogId) dim catidRS, strsql CurrentCategoryCount=0 If not isnumeric(catalogId) then exit sub if catalogid="" then exit sub strsql="SELECT prodcategories.intcategoryid " strsql=strsql & " FROM prodcategories, categories " strsql=strsql & " Where prodcategories.intcategoryid = categories.categoryid " ' strsql=strsql & " AND categories.highercategoryid=0 " strsql=strsql & " AND prodcategories.intcatalogid=" & 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 GenerateSelectTable (table, selectname, currentvalue, Firstfield, sortfield, rsfieldname, rsdisplayfield) dim suppconn %>" exit sub end if end if end if If ucase(table)="SUPPLIERS" and getconfig("xproductdb")<>"" then shopopendatabase suppconn Set genrs=suppconn.execute(gensql) else Set genrs=myconn.execute(gensql) end if ' 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 If ucase(table)="SUPPLIERS" and getconfig("xproductdb")<>"" then shopclosedatabase suppconn end if End Sub Sub AddProductOtherFields dim words(50),wordcount, captions(50), capcount,i if getconfig("xProductOtherFields")<>"" then GenerateDisplayHeader "Customer Created Fields" GenerateDisplayBodyHeader response.write "" 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 response.write "
" GenerateDisplayBodyFooter 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","" strhighercatalogid=request("highercatalogid") end sub Sub PCreateRowText (caption, fieldname, fieldvalue, rows, realname) dim url, htmlurl, linkurl url="shopa_addproduct.asp?which=" & which htmlurl="shopa_htmledit.asp?which=" & which & "&idfield=catalogid&table=products&fieldname=" & realname htmlurl=htmlurl & "&url=" & server.urlencode(url) Linkurl="" & "HTML edit" & "" Response.write tablerow & "" & caption 'If getconfig("xhtmleditor")="Yes" then ' If realname<>"" and which<>"" Then ' Response.write "
" & linkurl ' end if 'end if response.write tablecolumnend & "" 'response.write "" 'VPASP 600 - ADD HTML EDITOR If getconfig("xhtmleditor")="Yes" then addHTMLEditor fieldname, fieldvalue, "addproduct" else response.write "" end if response.write "" 'FormatEditHelp fieldname, helpfile response.write "" end sub Sub PCreateRowDisplay (caption, fieldname, fieldvalue) Response.write tablerow & tablecolumn & caption & tablecolumnend response.write "" & fieldvalue & tablecolumnend 'FormatEditHelp fieldname, helpfile Response.write tablerowend end sub Sub DeleteRecord dim myconn, idfield, sql, url idfield="catalogid" Gettable EditOpenDatabase myconn, database,dbtable sql="delete from " & dbtable & " where " & idfield & "=" & which myconn.execute(sql) sql="delete from prodcategories where intcatalogid=" & which myconn.execute(sql) shopclosedatabase myconn url="shopa_editdisplay.asp?table=" & dbtable responseredirect url end sub Sub PcreateHiddenField(fieldname, fieldvalue) response.write "" & vbcrlf end sub '********************************************************************** ' fix yes nos nov 13, 2005 '****************************************************************** Sub SetupYesnos Yesnos(0)=replace(getlang("langcommonYes")," ","") Yesnos(1)=replace(getlang("LangCommonNo")," ","") Yesvalue=yesnos(0) novalue=yesnos(1) Yesnocount=2 end sub '*********************************************************************** ' Put out inventory products display ' if it is a sub product don't put out form but add hidden field '*********************************************************************** Sub AddInventoryForm dim featuretypes(10),featuretypecount, headertext 'strhassubproduct=Determinesubproduct Const FeaturetypeList="Dropdown,Radio,Table,Quantity,Checkbox" parserecord featuretypelist, featuretypes, featuretypecount,"," if which <> "" then if strhighercatalogid<>"" then headerText =getlang("LangInventory") else If getconfig("xhtmleditor")="Yes" then headertext = "" else headertext = "" end if headerText = headertext & "" headerText = headertext & "
" & getlang("LangInventory") & " 
" end if else headerText = getlang("LangInventory") end if GenerateDisplayHeader headerText GenerateDisplayBodyHeader response.write "" if strhighercatalogid<>"" then strhassubproduct="" PCreateRow "Parent Product ID","highercatalogid", strhighercatalogid response.write "
" GenerateDisplayBodyFooter exit sub else 'PCreateHiddenField "highercatalogid",strhighercatalogid PCreateRow "Parent Product ID","highercatalogid", strhighercatalogid end if 'PCreateRow getlang("LangInventory"),"strinventoryproducts",strinventoryproducts Response.write tablerow & "" & getlang("Langinventorydisplaytype") & tablecolumnend response.write "" GenerateselectNV featuretypes,strspdisplaytype,"strspdisplaytype",featuretypecount, getlang("langcommonselect") response.write ("") 'PCreateRow "Original catalogid","strhighercatalogid", strhighercatalogid If strhassubproduct="" then strhassubproduct=novalue end if Response.write tablerow & tablecolumn & "Has Sub-Products?" & tablecolumnend & "" response.write " Yes" response.write " "Yes" then response.write " checked" response.write "> No" response.write ("") Response.write tablerow & " " AddInventoryLinkMenu myconn, which, dbtable response.write "" GenerateDisplayBodyFooter end sub Sub AddInventoryLinkMenu (myconn, which, dbtable) dim fieldnames(100), fieldcount, i, fieldname, sql, rs, captions(100) dim scriptresponder, keytable, viewresponder If strhighercatalogid<>"" then exit sub if which="" then exit sub sql="Select * from products where" if strinventory<>"" then sql=sql & " catalogid in (" & strinventory & ") or " end if sql=sql & " highercatalogid=" & which set rs=myconn.execute(sql) if rs.eof then response.write ""'" 'GenerateDisplayBodyFooter closerecordset rs exit sub end if fieldcount=0 AddDisplayfield fieldnames, fieldcount, captions, "cname",getlang("langproductname") AddDisplayfield fieldnames, fieldcount, captions, "cdescription",getlang("langproductdescription") response.write ReportTabledef response.write "" for i = 0 to fieldcount-1 response.write ReportHeadColumn & captions(i) & ReportHeadColumnEnd next response.write " " response.write ReportRowEnd do while not rs.eof InventoryDisplayRecorddetails rs, fieldnames, fieldcount, scriptresponder rs.movenext loop closerecordset rs response.write "" end sub sub AddDisplayfield (fieldnames, fieldcount, captions, fieldname,caption) fieldnames(fieldcount)=fieldname captions(fieldcount)=caption fieldcount=fieldcount+1 end sub Sub InventoryDisplayrecordDetails (rs, fieldnames, fieldcount, scriptresponder) dim i, id, idfield dim fieldvalue, fieldname, my_link, keyid response.write tablerow for i = 0 to fieldcount-1 id=rs(0) fieldname=fieldnames(i) fieldvalue=rs(fieldname) response.write "" & fieldvalue & ReportDetailColumnEnd next keyid="catalogid" idfield="catalogid" my_link=scriptresponder & "?table=" & "products" & "&which=" & id & "&idfield=" & idfield & "&highercatalogid=" & which fieldvalue="" & getlang("langcommonEDit") & "" response.write "" & fieldvalue & ReportDetailColumnEnd response.write ReportRowEnd end sub '********************************************************************************* ' If this is a sub product then add link back to main product '********************************************************************************** Sub addmainproductLink if strhighercatalogid="" then strhighercatalogid=request("highercatalogid") end if if strhighercatalogid<>"" then response.write "

" shopwriteheader "This is a Sub-Product for Catalog ID: " & strhighercatalogid & "
" end if end sub '*************************************************************************** ' we are adding a sub product. populate fields from that sub product '*************************************************************************** sub Populatefromexistingproduct ' populate fields from higher product dim savehighercatalogid, savelngcatalogid savehighercatalogid=strhighercatalogid setsess "productid",strhighercatalogid savelngcatalogid=lngcatalogid lngcatalogid=strhighercatalogid Getexistingproduct ' read existing product lngcatalogid="" ' product has not been added which="" strhighercatalogid=savehighercatalogid strHasSubProduct= "" ' make sure sub product null end sub '************************************************************************ ' see if this product has subproducts '************************************************************************ Function Determinesubproduct dim sql, rs, yesno yesno="" if strinventory<>"" then Yesno="Yes" else if which<>"" then sql="select catalogid from products where highercatalogid=" & which set rs=myconn.execute(sql) if not rs.eof then yesno="Yes" end if closerecordset rs end if end if determinesubproduct=yesno end function '*********************************************************************************************** ' display current categories and then allows persoon to select main category and any subcategories ' three displays are shown ' general list of all categories ' main category selection ' all other categories ' *********************************************************************************************** sub AddCategories If getconfig("xCategoriesSimple")="Yes" then PerformCategoriesSimple exit sub end if getallcategories ' create an array of all categories Response.Write "" 'GeneratemaincategorySelection ' drop down of all main categories Generateallcategoryselection ' drop down of all actegories If strhighercatalogid<>"" and which="" then GetCurrentCategories strhighercatalogid else If which<>"" then GetCurrentCategories lngcatalogid end if end if if currentcategorycount>0 then response.write "" response.write "" response.write "") 'FormatEditHelp "ccategory", helpfile Response.write "" end sub '**************************************************************************************** ' list all categories/subcategories except if 'xaddproductsubcategorybycategory=Yes tghen only list subcategories ' belonging to this category ' does not subport sub sub categories '**************************************************************************************** sub GenerateAllcategoryselection dim limitfield limitfield="" if getconfig("xaddproductsubcategorybycategory")="Yes" then ' if lngccategory="" then ' exit sub ' else ' limitfield=lngccategory ' end if end if response.write tablerow & "") 'FormatEditHelp "ccategory", helpfile response.write "" end sub '************************************************************************************************ ' used to generate single selections for main and subcategories ' limit field allows to limit to only main categories when set to 0 '********************************************************************************************* sub GeneratemaincategoryFormField (selectname, currentvalue, firstfield, limitfield) dim rsfieldsvalue, displayfieldvalue, highercategoryid, i, display response.write "" end sub sub Getallcategories '********************************************************************************************** ' get all categories ' use xmaxcategories or whichever is higher '********************************************************************************************* dim rs, sql, arraysize, i, highercategoryid, hidden arraysize=getconfig("Xmaxcategories") arraysize=clng(arraysize) sql="select * from categories order by categoryid" set rs=myconn.execute(sql) i=0 recordcount=rs.recordcount if isnumeric(recordcount) and recordcount>0 then arraysize=recordcount end if redim categoryarray(arraysize,5) do while not rs.eof categoryarray(i,dccatdescription)=rs("catdescription") categoryarray(i,dccatlinks)=rs("catdescription") categoryarray(i,dccategoryid)=clng(rs("categoryid")) highercategoryid=rs("highercategoryid") if isnull(highercategoryid) then highercategoryid=0 categoryarray(i,dchighercategoryid)=highercategoryid hidden=rs("cathide") if not isnull(hidden) then categoryarray(i,dcnote)="hidden" end if If categoryarray(i,dccategoryid)=lngccategory then categoryarray(i,dcnote)=getlang("maincategory") end if categoryarray(i,dchassubcategory)=rs("hassubcategory") rs.movenext i=i+1 loop categorycount=i closerecordset rs if categorycount>0 then GenerateCategoryLinks ' generate links to categories end if end sub '************************************************************************************************ ' generate links in form cat--- subcat---subcat '*********************************************************************************************** Sub GenerateCategorylinks dim i, catlink, categoryid,j, sep sep="---" 'VP-ASP 6.09 - check if higercategoryid has been set to categoryID for categories dim caterror caterror= 0 for i = 0 to categorycount-1 catlink=categoryarray(i,dccatdescription) highercategoryid=categoryarray(i,dchighercategoryid) categoryid=categoryarray(i,dccategoryid) 'VP-ASP 6.09 - check if higercategoryid has been set to categoryID for categories if clng(categoryid)=clng(highercategoryid) then if caterror = 0 then response.write "CategoryID/HigherCategoryID Conflicts
" caterror = 1 end if highercategoryid=0 response.write "Higher Category ID is the same as the Category ID for Record #" & categoryid & ". Please update this record manually.
" end if do while highercategoryid<>0 j=Findincatarray(highercategoryid) ' find entry for higher category if j =-1 then exit for ' not found catdescription=categoryarray(j,dccatdescription) catlink=catdescription & sep & catlink ' generate higher--- cat highercategoryid=categoryarray(j,dchighercategoryid) ' see if it has a higher categgoryid loopcount=loopcount+1 'if loopcount>10 then ' exit for 'end if 'VP-ASP 6.09 - check if higercategoryid has been set to categoryID for categories if clng(categoryarray(j,dccategoryid))=clng(highercategoryid) then if caterror = 0 then response.write "CategoryID/HigherCategoryID Conflicts
" caterror = 1 end if highercategoryid=0 response.write "Higher Category ID is the same as the Category ID for Record #" & categoryid & ". Please update this record manually.
" end if loop catlink=catlink & " (" & categoryid & ")" 'if categoryarray(i,dchassubcategory) = "Yes" then ' categoryarray(i,dccatlinks)="" 'else categoryarray(i,dccatlinks)=catlink 'end if ' debugwrite "catlink=" & catlink next end sub Function Findincatarray(categoryid) dim z for z=0 to categorycount-i catid=categoryarray(z,dccategoryid) if catid=categoryid then findincatarray=z exit function end if next findincatarray=-1 end function '************************************************************************************************ 'display all current categories '************************************************************************************************* sub Displayallcurrentcategories dim i, j, categoryid, fieldvalue, removelink for i = 0 to currentcategorycount-1 categoryid=currentcategories(i) j=Findincatarray(categoryid) if j<>-1 then catlink=categoryarray(j,dccatlinks) ' if categoryid<>lngccategory then removelink="shopa_removecategory.asp?catalogid=" & which & "&categoryid=" & categoryid fieldvalue="" & getlang("langcommonDelete") & "" ' else ' fieldvalue= getlang("langmaincategory") ' end if else fieldvalue="Category not found " & categoryid end if ' if fieldvalue <> getlang("langmaincategory") then Response.write tablerow & "") 'FormatEditHelp "ccategory", helpfile Response.write "" end sub Sub GenerateSimpleSubcategoryselection response.write tablerow & tablecolumn & getlang("LangProductSubCategory") & tablecolumnend response.write tablecolumn GeneratesimplecategoryFormField "subcategoryid", lngSubcategoryid,getlang("langcommonselect"),"" response.write ("") 'FormatEditHelp "subcategoryid", helpfile Response.write "" end sub '******************************************************************************************** ' two values are used ' lngccategory, strcatlist ' which=catalogi ' lngccategory=main category ' strcatlist is other category '******************************************************************************************* Sub Performaddcategory dim categoryid, sql, rs which=request("which") lngcatalogid=which if which="" then saction="ADD" exit sub end if dbtable="products" lngccategory=request("lngccategory") strcategorylist=request("strcategorylist") if not isnumeric(which) then serror="catalogid missing for add category" exit sub end if updatemaincategory which, lngccategory updateothercategory which, strcategorylist end sub '*************************************************************************************** ' updates prodcategories table and ccategory field in product record '************************************************************************************** sub Updatemaincategory(catalogid, lngccategory) dim rs, found, sql If lngccategory=cSelect then lngccategory="" else if not isnumeric(lngccategory) then lngccategory="" end if end if if lngccategory="" then exit sub end if sql="select * from prodcategories where intcategoryid=" & lngccategory & " and intcatalogid=" & catalogid 'debugwrite sql set rs=myconn.execute(sql) if not rs.eof then found=true else found=false end if closerecordset rs If found=false then sql="insert into prodcategories (intcategoryid,intcatalogid) values (" & lngccategory & "," & catalogid & ")" myconn.execute(sql) end if sql="update products set ccategory=" & lngccategory & " where catalogid=" & catalogid myconn.execute(sql) end sub '*************************************************************************************** ' updates prodcategories table and ccategory field in product record '************************************************************************************** sub UpdateOthercategory(catalogid, categoryid) dim found, rs If categoryid=cSelect then exit sub end if if not isnumeric(categoryid) then categoryid="" end if if categoryid="" then sError = sError & getlang("LangProductCategory") & " " & getlang("langcustrequired") & "
" exit sub end if sql="select * from prodcategories where intcategoryid=" & categoryid & " and intcatalogid=" & catalogid 'debugwrite sql set rs=myconn.execute(sql) if not rs.eof then found=true else found=false end if closerecordset rs If found=false then sql="insert into prodcategories (intcategoryid,intcatalogid) values (" & categoryid & "," & catalogid & ")" myconn.execute(sql) end if end sub '3/1/2006 when adding a product, add records to prodcategories for copy sub Updateprodcategories(originalcatalogid,copycatalogid) if originalcatalogid = "" then exit sub if isnull(originalcatalogid) then exit sub dim found, rs,pcrs sql="select * from prodcategories where intcatalogid=" & originalcatalogid set rs=myconn.execute(sql) while not rs.eof sql="select * from prodcategories where intcategoryid = " & rs("intcategoryid") & " AND intcatalogid=" & copycatalogid set pcrs=myconn.execute(sql) if not pcrs.eof then found=true else found=false end if closerecordset pcrs If found=false then sql="insert into prodcategories (intcategoryid,intcatalogid) values (" & rs("intcategoryid") & "," & copycatalogid & ")" myconn.execute(sql) end if rs.movenext wend closerecordset rs end sub Sub addsynchronizelink dim removelink, fieldvalue if strhighercatalogid="" then exit sub removelink="shopa_categoryproductsync.asp?catalogid=" & which & "&oldcatalogid=" & strhighercatalogid fieldvalue="" & "Make categories same as product " & strhighercatalogid & "" response.write "
" response.write fieldvalue end sub sub GenerateSimplecategoryFormField (selectname, currentvalue, firstfield, limitfield) dim rsfieldsvalue, displayfieldvalue, highercategoryid, i, display response.write "" end sub Sub UpdateProduct dim sqlo, rso, filtersql CorrectbooleanHuman boolhide CorrectbooleanHuman strtaxfree CorrectbooleanHuman strfreeshipping 'VP-ASP 6.50 - flag to determine if product should appear in Featured Products listing CorrectbooleanHuman strfeaturedflag 'VP-ASP 6.50 - flag to determine if customer should be allowed to upload an image CorrectbooleanHuman strcustomerimage 'VP-ASP 6.50 - broadened defintion of IF statement to cover cases where xmysql hasn't been set if ucase(xdatabasetype) = "MYSQL" OR ucase(xdatabasetype) = "MYSQL351" OR getconfig("xMYSQL")="Yes" then MYSQLUpdateproduct which=getsess("productid") exit sub end if 'VP-ASP 6.09 - unused due to new features selection list 'GetProductFeatures GetCrossSelling2 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 '========================= 'VP-ASP 600 - insertion of date product was added '12/10/2005 '========================= pupdatefield "cdateupdated", now() ' time and date product last updated '========================= else objRS.open "products", myconn, adOpenKeyset, adLockOptimistic objRS.AddNew '========================= 'VP-ASP 600 - insertion of date product was added '12/10/2005 '========================= pupdatefield "cdateadded", now() ' time and date product was added pupdatefield "cdateupdated", now() ' time and date product last updated '========================= end if pupdatefield "ccode", strccode pupdatefield "cname", strcname pupdatefield "cdescription", memcdescription pupdatefield "cprice", curcprice 'pupdatefield "ccategory", lngccategory pupdatefield "category", strcategory pupdatefield "features", strfeatures '========================= 'VP-ASP 600 - insertion of page impressions '12/10/2005 '========================= if (strimpressions = "") or (isnull(strimpressions)) then strimpressions = 0 end if pupdatefield "impressions", strimpressions '========================= 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 "level3", strlevel3 pupdatefield "level4", strlevel4 pupdatefield "level5", strlevel5 pupdatefield "subcategoryid", lngsubcategoryid pupdatefield "specialoffer", strspecialoffer pupdatefield "retailprice", strretailprice pupdatefield "allowusertext", strallowusertext 'VP-ASP 6.50 - flag to determine if product should appear in Featured Products listing pupdatefield "featuredflag", strfeaturedflag 'VP-ASP 6.50 - flag to determine if customer should be allowed to upload an image pupdatefield "customerimage", strcustomerimage 'VP-ASP 6.50 - how many days after purchase the customer is allowed to submit an RMA for this product pupdatefield "rmadays", strrmadays pupdatefield "template", strtemplate '========================= 'VP-ASP 600 - insertion of template for shopdisplayproducts listing '14/10/2005 '========================= pupdatefield "templatelisting", strtemplatelisting '========================= pupdatefield "extendeddesc", memexdesc pupdatefield "extendedimage", strextendedimage pupdatefield "selectlist", strselectlist pupdatefield "keywords", strkeywords pupdatefield "minimumquantity", strminimumquantity pupdatefield "supplierid", strsupplierid pupdatefield "crossselling", strcrossselling pupdatefield "clanguage", strclanguage pupdatefield "groupfordiscount", strgroupfordiscount pupdatefield "orderattachment", strattachment pupdatefield "orderdownload", strdownload pupdatefield "customermatch", strcustomermatch pupdatefield "productmatch", strproductmatch pupdatefield "hide", boolhide pupdatefield "points", strpoints pupdatefield "pointstobuy", strpointstobuy pupdatefield "price2", strprice2 pupdatefield "price3", strprice3 pupdatefield "maximumquantity", strmaximumquantity '5.0 pupdatefield "frontpage", strfrontpage '5.0 pupdatefield "billprice",strbillprice '5.0 pupdatefield "billinstallments",strinstallments '5.0 pupdatefield "billinstallmenttype",strinstallmenttype '5.0 pupdatefield "billinterval",strinstallmentinterval pupdatefield "inventoryproducts",strinventoryproducts ' 5.50 pupdatefield "taxfree",strtaxfree ' 5.50 pupdatefield "freeshipping",strfreeshipping ' 5.50 pupdatefield "highercatalogid", strhighercatalogid ' 6.0 pupdatefield "hassubproduct", strHasSubProduct ' 6.0 pupdatefield "spdisplaytype", strSPDisplayType ' 6.0 if strproductuserid="" then pupdatefield "userid", getsess("shopadmin") ' user that added product else pupdatefield "userid", strproductuserid ' user that added product end if 'VP-ASP 6.50 - added extra image fields pupdatefield "extraimage1", strimageextra1 ' 6.5 pupdatefield "extraimage2", strimageextra2 ' 6.5 pupdatefield "extraimage3", strimageextra3 ' 6.5 pupdatefield "extraimage4", strimageextra4 ' 6.5 pupdatefield "extraimage5", strimageextra5 ' 6.5 UpdateProductOtherFields objrs objrs.update lngcatalogid=clng(objrs("catalogid")) which=lngcatalogid setsess "productid",lngcatalogid objrs.close set objrs=nothing UpdateCategory lngCatalogId, strCategoryList, lngccategory end Sub Sub UpdateParentProduct (strhighercatalogid) if strhighercatalogid > "" then sql="update products set hassubproduct='Yes' where catalogid = " & strhighercatalogid myconn.execute(sql) end if End Sub 'VP-ASP 6.50 - generate individual static page Sub GenerateStaticPage shopclosedatabase myconn which=request("which") dim url url="shopa_generateproducthtml.asp?which=" & which responseredirect url end sub Sub GenerateFeatureSelect (iFieldnames,iFieldvalues,fieldcount,currentvalues,currentvaluecount, selectname,firstfield) ' Generates select with no values %> <% end sub %>
 
" & getlang("LangCommonCategories") & ReportHeadColumnEnd response.write ReportHeadColumn & " " & ReportHeadColumnEnd response.write ReportRowEnd Displayallcurrentcategories ' display all current categories end if Response.Write tabledefend if which<>"" then AddSynchronizelink end if end sub sub Generatemaincategoryselection response.write tablerow & tablecolumn & getlang("langmaincategory") & tablecolumnend response.write tablecolumn GeneratemaincategoryFormField "lngCcategory", lngccategory,getlang("langcommonselect"),0 'response.write ("
Categories" & tablecolumnend response.write tablecolumn 'GeneratemaincategoryFormField "strcategorylist", strcategorylist,getlang("langcommonselect"),"" GeneratemaincategoryFormField "strcategorylist", strcategorylist,getlang("langcommonselect"),limitfield response.write ("" if which <> "" then If getconfig("xhtmleditor")="Yes" then %><% else %><% end if end if Response.write "
" & catlink & tablecolumnend Response.write "" & fieldvalue & tablecolumnend response.write tablerowend ' end if next end sub '************************************************************************************ ' This is original VP-ASP. Only one category and one subcategory are used ' prodcategories table is not used '************************************************************************************ Sub PerformcategoriesSimple dim curentcategory, currentsubcategory getallcategories ' create an array of all categories Response.Write tabledef pHeaderrow getlang("LangCommonCategories") & " " & "Simple Mode" ' dispolay a header row for this table GeneratesimplemaincategorySelection GeneratesimpleSubcategoryselection Response.Write tabledefend 'Response.Write("") 'if which<>"" then ' AddSynchronizelink 'end if end sub sub GenerateSimplemaincategoryselection response.write tablerow & tablecolumn & getlang("langmaincategory") & tablecolumnend response.write tablecolumn GenerateSimplecategoryFormField "lngCcategory", lngccategory,getlang("langcommonselect"),0 response.write ("