<%option explicit%> <% 'VP-ASP 6.08 - removed parameter from shopcheckadmin so users with limited access can use this page ShopCheckAdmin "" '******************************* ' Version 6.50 Supports adds, deletes, updates ' Display fields in one record of one table ' setting field to keyword "NULL" sets field to empty ' March 8, 2004 '******************************* dim rstemp dim which dim idfield dim dbtable, AddAction, conn, updateaction dim DeleteAction Addaction=Request.form("add") Updateaction=Request.form("update") Deleteaction=request("delete") GetInputValues If DeleteAction<>"" then DeleteRecord end if EditOpenDatabase conn, database,dbtable If Addaction = "" and Updateaction = "" Then AdminPageHeader GenerateForm AdminPageTrailer Else AdminPageHeader UpdateRecord GenerateForm AdminPageTrailer end if Shopclosedatabase conn '************************ Sub GetInputValues ' ID, allows editing a record which=request("which") 'VP-ASP 6.09 - Precautionary Security Fix if which > "" then If not isnumeric(which) then shoperror "ID must be numeric" end if end if idfield=request("idfield") dbtable=request("table") ValidateTable End Sub ' Sub ValidateTable '******************************************** 'See if user has access to this table Dim UserTables, i dim tablecount if getconfig("XRestrictAdminTables")<>"Yes" then exit sub UserTables=GetSess("UserTables") If Isnull(UserTables) then exit sub end if if UserTables="" then exit Sub else UserTables=split(GetSess("UserTables"),",",-1,1) end if tablecount=ubound(UserTables) for i = 0 to tablecount if ucase(dbtable)=ucase(Usertables(i)) then exit sub end if next dbtable="" end sub Sub GenerateForm dim sqltemp sqltemp="select * from " & dbtable if which <> "" then sqltemp=sqltemp & " where " & idfield & "=" & which end if 'debugwrite sqltemp set rstemp=conn.execute(sqltemp) DisplayForm rstemp.close set rstemp=nothing gethelp dbtable end Sub '**************************** Sub DisplayForm() dim keyvalue, howmanyfields, i, fieldname, fieldvalue, fieldtype, fieldtypenum howmanyfields=rstemp.fields.count -1 %> <%'VP-ASP 6.09 - restore error display if serror > "" then%> <%end if%>

<%shopwriteheader ucase(left(dbtable, 1)) & right(dbtable, len(dbtable) - 1) & " Setup"%>

<% dim returntopage select case dbtable case "orders" returntopage = "shopa_displayorders.asp" case "projects" returntopage = "shopa_projectdisplay.asp" case "registrant" returntopage = "shopa_giftregdisplay.asp" case "oitems" 'VP-ASP 6.50 - remember where to go back to returntopage = "shopa_displayoitems.asp?orderid=" & request("which") case "tblaccess" returntopage = "shopa_menu_control.asp" case else returntopage= "shopa_editdisplay.asp?which=" & which & "&table=" & dbtable & "&idfield=" & idfield end select response.write "" response.write "" %>

Back To " & ucase(left(dbtable, 1)) & right(dbtable, len(dbtable) - 1) & "

<%shopwriteerror sError%>

<% GenerateDisplayHeader "Basic Information" GenerateDisplayBodyHeader response.write "

" 'VP-ASP 6.50 - Added buttons to top of page as well as bottom Response.write "" If which<>"" then Response.Write("") Response.Write(" ") Response.Write(" ") else Response.Write("") end if response.write "" response.write "

" Response.Write "" for i=0 to howmanyfields fieldname = rstemp(i).name If i=0 then idfield=fieldname If which<>"" then fieldvalue = rstemp(i).value else fieldvalue="" end if fieldtypenum = rstemp(i).type 'VP-ASP 6.09 - fix for larger SQL Server varchars not showing in a textarea Fieldtype=GetTypename(fieldTypenum, rstemp(i)) ' ' debugwrite fieldname & " " & fieldtypenum & " " & fieldtype If i=0 then if fieldvalue > "" then idfield=fieldname FormatEditRowStatic "",fieldname,fieldvalue end if else 'VP-ASP 6.50 - quick add to hacker table from shopa_formatorder.asp if (lcase(dbtable) = "hackers") and (lcase(fieldname) = "ipaddress") and (request.QueryString("ip") > "") then FormatEditRow "",fieldname,request.QueryString("ip") elseif (lcase(dbtable) = "hackers") and (lcase(fieldname) = "email") and (request.QueryString("email") > "") then FormatEditRow "",fieldname,request.QueryString("email") elseif lcase(fieldname) = "fldsection" then response.write "" 'VP-ASP 6.50 - display captions in a textarea to allow for double quotes in captions elseif (lcase(dbtable) = "languages") AND (lcase(fieldname) = "caption") then FormatEditRowTextarea "",fieldname,fieldvalue else If Fieldtype<>"Memo" then FormatEditRow "",fieldname,fieldvalue else FormatEditRowTextarea "",fieldname,fieldvalue end if end if end if next Response.Write(TableDefEnd) response.write "

" Response.write "" If which<>"" then Response.Write("") Response.Write(" ") 'VP-ASP 6.50 - Moved Delete button to be on same line as Add and Update Response.Write(" ") else Response.Write("") end if response.write "" AddHiddenFields 'else ' response.write "

No records found

" 'end if Response.Write("") GenerateDisplayBodyFooter AddImageupload end sub '************ ' Sub UpdateRecord if dbtable ="tbllog" OR dbtable ="ups_config" then Shopclosedatabase conn shoperror "Editing this table is not allowed." exit sub end if dim sqltemp '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 MYSQLProcessrecord updateaction, conn, dbtable, idfield, which exit sub end if If updateaction<>"" then sqltemp="select * from " & dbtable sqltemp= sqltemp & " where " & idfield & "=" & which Set rstemp = Server.CreateObject("ADODB.Recordset") rstemp.open sqltemp, conn, 1, 3 else Set rstemp = Server.CreateObject("ADODB.Recordset") rstemp.open dbtable, conn, adOpenKeyset, adLockOptimistic rstemp.AddNew end if GenerateUpdateSQL which = rstemp(idfield) 'VP-ASP 6.09 - check if higercategoryid has been set to categoryID for categories if lcase(dbtable) = "categories" then dim temphighercat temphighercat = rstemp("highercategoryid") end if rstemp.close set rstemp=nothing If addaction<>"" then sError= sError & "
" & getlang("LangProductAdded") & " " & which & "" else sError= sError & "
" & getlang("LangEdit03") & "" end if 'VP-ASP 6.09 - check if higercategoryid has been set to categoryID for categories if lcase(dbtable) = "categories" then if clng(temphighercat) = clng(which) then serror=serror & "Higher Category ID is the same as the Category ID! Please change the Higher Category ID for this record.
" end if end if end sub ' ******** general Sql Sub GenerateUpdateSQL() Dim howmanyfields dim fieldname, fieldvalue, fieldtype dim i, typename howmanyfields=rstemp.fields.count -1 rstemp.update for i=1 to howmanyfields fieldname = rstemp(i).name fieldtype=rstemp(i).type fieldvalue = request.form(fieldname) 'VP-ASP 6.09 - fix for larger SQL Server varchars not showing in a textarea typename=GetTypename(fieldtype, rstemp(i)) 'EUpdatefield fieldname,fieldvalue, fieldtype EUpdatefield fieldname,fieldvalue, typename next rstemp.update end sub Sub EUpdateField (fieldname, fieldvalue, typename) on error resume next 'Debugwrite fieldname & "value=" & fieldvalue normalizefieldvalue fieldvalue, typename if fieldvalue="" then if which<>"" then rstemp(Fieldname)=NULL end if exit sub end if if ucase(fieldvalue)="NULL" then if which<>"" then rstemp(Fieldname)=NULL end if else rstemp(Fieldname)=fieldvalue end if end sub Function GetTypeName(id, object) Select Case id Case "3" GetTypeName = "Number" Case "200" GetTypeName = "Text" 'VP-ASP 6.09 - fix for larger SQL Server varchars not showing in a textarea if object.definedsize >= 500 then GetTypeName = "Memo" end if Case "129" GetTypeName = "Text" Case "201","203" GetTypeName = "Memo" Case "6" GetTypeName = "Currency" Case "11" GetTypeName = "YesNo" Case "5" GetTypeName = "Number" Case "7", "133","134","135" GetTypeName = "DateTime" Case Else GetTypeName = "Text" End Select End Function Sub Normalizefieldvalue (value, itype) dim uvalue if itype="YesNo" then if value="0" or value = "1" then exit sub uvalue=ucase(value) if uvalue="TRUE" or uvalue="YES" then value=1 exit sub end if If (uvalue="FALSE") or (uvalue="") then value=0 exit sub end if value=0 exit sub end if end sub Sub AddImageUpload dim uploadurl, dbfield, fieldvalue dbfield="catimage" if getconfig("xupload")<>"Yes" then exit sub If lcase(dbtable)<>"categories" then exit sub uploadurl="shopa_upload.asp?id=" & which & "&field=" & dbfield & "&table=" & dbtable & "&idfield=" & idfield & "&url=" & server.urlencode("shopa_edit.asp") Response.write "

" & getlang("langupload") & "

" end sub Sub AddHiddenFields Formathiddenfield "idfield",idfield Formathiddenfield "which",which Formathiddenfield "table",dbtable end sub Sub FormatHiddenField (fieldname, fieldvalue) response.write "" & vbcrlf end sub Sub DeleteRecord dim myconn EditOpenDatabase myconn, database,dbtable dim sql, url sql="delete from " & dbtable & " where " & idfield & "=" & which myconn.execute(sql) shopclosedatabase myconn url="shopa_editdisplay.asp?table=" & dbtable responseredirect url end sub %>

Section

" dim sectionArray sectionArray = split("everyday,occasional", ",") GenerateSelectNV sectionArray,fieldvalue,fieldname, 2,"" response.write "