<%option explicit%>
<%
'**************************************************************************
' Version 6.50 Version add/delete userids
' adds or updates individual user privileges
' April 9, 2004 add language handling
'**************************************************************************
dim objrec, id, user, msg, admintype, item, d
'VP-ASP 6.00 - Allow tables from split databases to be selected
dim affcon, custcon, ordercon, productcon, projectcon, searchcon
Dim Menuaccess, menulist
ShopCheckAdmin "shopa_user_control.asp"
sError=""
ShopOpenDatabase con
AdminPageHeader
'VP-ASP 6.00 - Allow tables from split databases to be selected
if getconfig("xaffiliatedb") > "" then
OpenAffiliateDB affcon
end if
if getconfig("xcustomerdb") > "" then
OpenCustomerDB custcon
end if
if getconfig("xorderdb") > "" then
OpenOrderDB ordercon
end if
if getconfig("xproductdb") > "" then
ShopOpenDatabaseP productcon
end if
if getconfig("xprojectdb") > "" then
ShopOpenOtherDB projectcon, getconfig("xprojectDb")
end if
if getconfig("xsearchdb") > "" then
ShopOpenOtherDB searchcon, getconfig("xSearchDb")
end if
If Not Request("submit")="" Then
ValidateFields
if sError="" then
UpdateFields
end if
End If
If Request("Delete")<>"" Then
For each item in Request("DeleteUser")
'VP-ASP 6.50 - added check to stop the last admin user from being deleted
dim drs
d = "select count(fldauto) AS numUsers from tbluser"
set drs = con.Execute(d)
if cint(drs("numUsers")) > 1 then
d = "delete from tbluser where fldauto = " & item
con.Execute(d)
else
shopwriteerror "You cannot delete the last user in the database. You must create a new admin user before deleting this entry. "
end if
closerecordset drs
Next
End If
Displayform
sql = "select * from tbluser"
Set objRec = con.Execute(SQL)
While Not objRec.EOF
id = objrec("fldauto")
user = objrec("fldusername")
menuaccess=objrec("fldaccess")
menulist=convertaccess(menuaccess)
admintype = objrec("admintype")
FormatMenuRow
objRec.MoveNext
wend
Closerecordset objRec
%>
<%
GenerateDisplayBodyFooter
DisplayForm2
gethelp
AdminPageTrailer
Shopclosedatabase con
'VP-ASP 6.00 - Allow tables from split databases to be selected
if getconfig("xaffiliatedb") > "" then
ShopCloseDatabase affcon
end if
if getconfig("xcustomerdb") > "" then
ShopCloseDatabase custcon
end if
if getconfig("xorderdb") > "" then
ShopCloseDatabase ordercon
end if
if getconfig("xproductdb") > "" then
ShopCloseDatabase productcon
end if
if getconfig("xprojectdb") > "" then
ShopCloseDatabase projectcon
end if
if getconfig("xsearchdb") > "" then
ShopCloseDatabase searchcon
end if
'
Sub ValidateFields
Serror=""
if Request("Access")="" then
sError= sError & getlang("LangAdminRequired") & " "
end if
if Request("TableAccess")="" then
sError= sError & getlang("LangAdminTableMissing") & " "
end if
if Request("UserName")="" then
sError= sError & getlang("LangAdminUserMissing") & " "
end if
if Request("Password")="" then
sError= sError & getlang("LangAdminPasswordMissing") & " "
end if
admintype=Request("admintype")
admintype=ucase(admintype)
end sub
Sub BuildTableAccess
Dim Tables, Tablecount, i
GetDatabaseTables Tables, tablecount, con
'VP-ASP 6.00 - Allow tables from split databases to be selected
if getconfig("xaffiliatedb") > "" then
GetDatabaseTablesPlus Tables, tablecount, affcon
end if
if getconfig("xcustomerdb") > "" then
GetDatabaseTablesPlus Tables, tablecount, custcon
end if
if getconfig("xorderdb") > "" then
GetDatabaseTablesPlus Tables, tablecount, ordercon
end if
if getconfig("xproductdb") > "" then
GetDatabaseTablesPlus Tables, tablecount, productcon
end if
if getconfig("xprojectdb") > "" then
GetDatabaseTablesPlus Tables, tablecount, projectcon
end if
if getconfig("xsearchdb") > "" then
GetDatabaseTablesPlus Tables, tablecount, searchcon
end if
For i=0 to tablecount -1
if lcase(tables(i)) <> "ups_config" then
response.write "" & Tables(i) & " "
end if
next
end sub
'
Sub BuildTypeAccess
%>
<%=getlang("LangNormalAdministrator")%>
<%=getlang("LangRestrictedAdministrator")%>
<%
end sub
Sub UpdateFields
Dim Dup, rs, item, access
Dim a
Dim tablelist
dim sqlo
dim username,fldauto,rso
username=request("Username")
dup = "select * from tbluser where fldusername = '" & username & "'"
Set rs = con.Execute(dup)
If Not rs.EOF Then
Serror = getlang("LangAdminDuplicate")
exit sub
end if
rs.close
set rs=nothing
sqlo="Insert into tbluser (fldUsername,fldaccess) VALUES('" & request("username") & "', ' ')"
con.execute(sqlo)
sqlo = "select max(fldauto) from tbluser where fldusername='" & username & "'"
Set rso = con.Execute(sqlo)
fldauto = rso(0)
rso.close
set rso=nothing
For each item in request("Access")
a = a & "," & item
Next
access = Right(a,Len(a)-1)
a=""
for each item in Request("TableAccess")
a = a & "," & item
next
tablelist = Right(a,Len(a)-1)
sqlo=""
updateaafield sqlo, "fldpassword",request("password")
updateaafield sqlo, "fldaccess",access
updateaafield sqlo, "tablesallowed",tablelist
updateaafield sqlo, "admintype",request("admintype")
sqlo="update tbluser " & sqlo & " where fldauto=" & fldauto
con.execute(sqlo)
end sub
Sub UpdateAAField (isql,fieldname,fieldvalue)
'on error resume next
if fieldvalue="" then
exit sub
end if
If getconfig("xdebug")="Yes" then
Debugwrite fieldname & " " & fieldvalue & " "
end if
if isql="" then
isql="SET "
else
isql=isql &","
end if
isql=isql & fieldname & "='" & fieldvalue & "'"
end Sub
Sub DisplayForm
If Serror<>"" then
shopwriteerror sError
end if
GenerateDisplayHeader getconfig("xemailname") & " Administrators"
GenerateDisplayBodyHeader
'shopwriteheader getlang("LangAdminAdministrators")
%>