api.asp

access管理系统API文件 把API文件上传到网站数据库目录下 再到ACCESS2008.CN 上

<%@LANGUAGE="VBSCRIPT" CODEPAGE="65001"%>
<%
'--------------------------------------------
'Access 数据库在线管理系统 API文件
'网址: http://www.access2008.cn
'--------------------------------------------
Response.Charset="utf-8"
Session.CodePage = "65001"
Response.Buffer = True 
Response.ExpiresAbsolute = Now() - 1 
Response.Expires = 0 
Response.CacheControl = "no-cache" 
Response.AddHeader "Pragma", "No-Cache"
Response.ContentType = "text/xml"

const mulu=".\" '数据库所在目录
const APIPASS="" '文件密码
const apiVersion="1.0.8" 'API版本
const apiVersionmun="108"
dim COArray:COArray = Array("Adodb.Connection","Adodb.RecordSet","Adox.CataLog","Adox.Table","Adox.Column","Adox.Index","Adox.Key","Msxml2.DOMDocument","JRO.JetEngine","Scripting.FileSystemObject")
dim cmd
dim text
dim filelj
dim mululj
dim comad:comad = Request("command")
dim APIFilePASS:APIFilePASS=request("APIFilePASS")
dim fs
set text = New TextData
If len(comad) > 0 Then
	if instr(mulu,":")=0 then
		mululj=server.MapPath(mulu)
	else
		mululj=mulu
	end if
	if right(mululj,1)="\" or right(mululj,1)="/" then
		mululj=left(mululj,len(mululj)-1)
	end if
	set fs = server.CreateObject(COArray(9))
	a=fs.FolderExists(mululj)
	set fs=nothing
	if a then
		if APIFilePASS=APIPASS or len(APIPASS)=0 then
			cmad(comad)
		else
			text.outerr text.gettxt(0)
		end if
	else
		text.outerr text.gettxt(1)
	end if
else
	text.outerr text.gettxt(2)
End If
function cmad(a)
	dim i,b,c
	dim a1,a2,a3,a4,a5,a6,a7,a8,a9,a10,a11,a12,a13,a14
	a1=Trim(Request("access"))
	a2=Trim(Request("table"))
	a3=Trim(Request("sl"))
	a4=Trim(Request("ys"))
	a5=Trim(Request("pass"))
	a6=Trim(Request("AbsolutePosition"))
	a7=Trim(Request("data"))
	a8=Trim(Request("bs"))
	a9=Trim(Request("field"))
	a10=Trim(Request("oldname"))
	a11=Trim(Request("newname"))
	a12=Trim(request("sql"))
	a13=Trim(Request("newpass"))
	a14=Trim(Request("type"))
	select case a
		case "index"
			call getaccess()
		case "gettable"
			b = split(a1,"|")
			if len(a5)>0 then
				c = split(a5,"|")
			else
				c= array(0)
				c(0)=""
			end if
			for i= 0 to ubound(b)
				call gettable(b(i),c(i))
			next
		case "getdatalist"
			call getdatalist(a1,a2,a3,a4,a5)
		case "deletedata"
			call deletedata(a1,a2,a3,a4,a6,a5)
		case "editdata"
			call editdata(a1,a2,a3,a4,a6,a7,a8,a5)
		case "getdata"
			call getdata(a1,a2,a6,a8,a5)
		case "getfield"
			call getfield(a1,a2,a9,a8,a5)
		case "fieldlist"
			call getfieldslist(a1,a2,a5)
		case "deletefield"
			call deletefield(a1,a2,a9,a5)
		case "editfield"
			call editfield(a1,a2,a9,a7,a8,a5)
		case "edittablename"
			call edittablename(a1,a5,a10,a11)
		case "newtable"
			call AddTable(a1,a5,a2)
		case "deletetable"
			call deletetable(a1,a5,a2)
		case "info"
			call banben()
		case "newdata"
			call newdata(a1)
		case "sqltext"
			call sqltext(a1,a5,a12,a4,a3)
		case "compressionaccess"
			call compressionaccess(a1,a5,"",1)
		case "editpass"
			call compressionaccess(a1,a5,a13,2)
		case "accessBackup"
			call accessBackup(a1,a8)
		case "accessLocale"
			call compressionaccess(a1,a5,a7,3)
		case "editPRIMARY"
			call editPRIMARY(a1,a2,a9,a5)
		case "editIndex"
			call editIndex(a1,a2,a9,a5,a14)
		case "serverinfo"
			call serverinfo()
		case "comlist"
			call comlist()
		case "Bandwidth"
			call Bandwidth()
		case else
			text.Start
			text.categoties "ok"
			text.Completed
	end select
end function
if comad="crossdomain" then
	Response.AddHeader "X-Permitted-Cross-Domain-Policies", "all"
	Response.Write("<?xml version=""1.0""?><cross-domain-policy><allow-access-from domain=""*.access2008.cn"" /></cross-domain-policy>")
else
	Response.Write(text.output)
end if
text.clase

sub banben()
	text.Start
	text.categoties "info"
	text.xmladd mululj,"mulu"
	text.xmladd apiVersion,"Version"
	text.xmladd apiVersionmun,"mun"
	text.Completed
end sub
function mdbjc(wjdz)
	On Error  resume next
	dim conn
	set conn = server.CreateObject(COArray(0))
	conn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Jet OLEDB:Database Password='';Data Source="&wjdz
	mdbjc= Err.Number
	conn.close
	set conn = nothing
end function
Function KJHS(INTS)
	dim b
	if ints>=(1024*1024*1024) then
		b=ints/(1024*1024*1024)
		kjhs=formatnumber(b,2,-1)&"GB"
	elseif ints>=(1024*1024) then
		b=ints/(1024*1024)
		kjhs=formatnumber(b,2,-1)&"MB"
	elseif ints>=1000 then
		b=ints/1024
		kjhs=formatnumber(b,2,-1)&"KB"
	else
		kjhs=ints&"字节"
	end if
end Function
sub accessBackup(ByVal a,ByVal b)
	On Error resume next
	dim c
	set fso = Server.CreateObject(COArray(9))
	if b="1" then
		fso.copyfile mululj&"\"&a, mululj&"\"&Left(a, InStrRev(a, ".")) & "bak"
	else
		fso.copyfile mululj&"\"&Left(a, InStrRev(a, ".")) & "bak", mululj&"\"&a
	end if
	if err.number<>0 then
		text.outerr err.Description
	else
		if b="1" then
			text.infoshow 3,4
		else
			text.infoshow 3,4
		end if
	end if
end sub
sub connaccess(a,ByVal c,ByVal d)
	set a = server.CreateObject(COArray(0))
	a.open "Provider=Microsoft.Jet.OLEDB.4.0;Jet OLEDB:Database Password='"&c&"';Data Source="&mululj&"\"&d
end sub
sub compressionaccess(ByVal a,ByVal b,ByVal t,ByVal e)
	on error resume next
	dim c,d,conn,xwjm,ee
	ee="Provider=Microsoft.Jet.OLEDB.4.0;Jet OLEDB:Database Password="
	set fso = Server.CreateObject(COArray(9))
	set jro = Server.CreateObject(COArray(8))
	call connaccess(conn,b,a)
	xwjm=fso.GetTempName
	c=ee&"'"&b&"';Data Source="&mululj&"\"&a
	if e=2 then
		d=ee&"'"&t&"';Data Source="&mululj&"\"&xwjm &";Locale Identifier=" & conn.Properties("Locale Identifier").value & "; Jet OLEDB:Engine Type=" & conn.Properties("Jet OLEDB:Engine Type")
	elseif e=3 then
		d=ee&"'"&b&"';Data Source="&mululj&"\"&xwjm &";Locale Identifier=" & t & "; Jet OLEDB:Engine Type=" & conn.Properties("Jet OLEDB:Engine Type")
	else
		d=ee&"'"&b&"';Data Source="&mululj&"\"&xwjm &";Locale Identifier=" & conn.Properties("Locale Identifier").value & "; Jet OLEDB:Engine Type=" & conn.Properties("Jet OLEDB:Engine Type")
	end if
	conn.close
	jro.CompactDatabase c,d
	if err.number<>0 then
		fso.deletefile mululj&"\"&xwjm
		if e=2 then
			text.outerr 6
		elseif e=3 then
			text.outerr 7
		else
			text.outerr 8
		end if
	else
		fso.DeleteFile mululj&"\"&a
		fso.MoveFile mululj&"\"&xwjm, mululj&"\"&a
		if e=2 then
			text.infoshow 9,4
			call gettable(a,t)
		elseif e=3 then
			text.infoshow 10,4
			call gettable(a,b)
		else
			text.infoshow 11,4
			call gettable(a,b)
		end if
	end if
end sub
sub sqltext(ByVal a,ByVal b,ByVal c,ByVal d,ByVal e)
	on error resume next
	dim conn,cmdTemp,rs
	call connaccess(conn,b,a)
	Set cmdTemp = Server.CreateObject("ADODB.Command")
    set rs=server.createobject(COArray(1))
    cmdTemp.CommandText = c
    cmdTemp.CommandType = 1
    Set cmdTemp.ActiveConnection = conn   
    rs.Open cmdTemp, ,1,3
	if err.Number<>0 then
        text.outerr err.Description
    else
	rs.pagesize=e
	text.start
	text.categoties "sqltabledata"
	text.xmladd a,"dataaccess"
	text.xmladd b,"dataaccesspass"
	text.xmladd c,"sql"
	text.xmladd d,"pagenow"
	text.xmladd rs.pageCount,"pageCount"
	text.xmladd rs.recordCount,"recordCount"
	for i=0 to rs.fields.count-1
		text.xmladd rs.fields(i).name,"fields"
	next
	if not (rs.eof or err) then rs.move (cint(d)-1)*cint(e)
	do while not (rs.eof or err)
		text.add "<data1>"
			text.xmladd rs.AbsolutePosition,"datashow"
			for i=0 to rs.fields.count-1
				select case rs.fields(i).type
					case 205
						if not isnull(rs(i)) then
							text.xmladd text.gettxt(12),"datashow"
						else
							text.xmladd "","datashow"
						end if
					case 128
						if not isnull(rs(i)) then
							text.xmladd text.gettxt(13),"datashow"
						else
							text.xmladd "","datashow"
						end if
					case 204
						if not isnull(rs(i)) then
							text.xmladd text.gettxt(14),"datashow"
						else
							text.xmladd "","datashow"
						end if
					case 203
						if len(rs(i))>100 then
							text.xmladd replace(left(rs(i),90)&"...",chr(13)&chr(10),""),"datashow"
						else
							text.xmladd rs(i),"datashow"
						end if
					case else
						text.xmladd rs(i),"datashow"
				end select
		next
		text.add "</data1>"
		j=j+1
		if j>=cint(e) then exit do
		rs.movenext
	loop
	text.Completed
	end if
end sub
sub newdata(ByVal a)
	On Error resume next
	dim cat
	set cat=server.createobject(COArray(2))   
    cat.Create "Provider=Microsoft.Jet.OLEDB.4.0;Data Source="&mululj&"/"&a&".mdb"
	call getaccess()
end sub
sub getaccess()
	dim fso,fsoml
	dim sjkbs
	dim j:j=0
 	Set fso = Server.CreateObject(COArray(9))
	Set fsom1= fso.getfolder(mululj)
	text.Start
	text.categoties "accessname"
	for each thing in fsom1.files
		if LCase(right(thing.name,len(thing.name)-InstrRev(thing.name,".")))<>"bak" then
			sjkbs=mdbjc(mululj&"\"&thing.name)
			if(sjkbs<>"-2147467259") then
				j=j+1
				if sjkbs="0" then
					text.add "<access title="""&thing.name&""" size="""&thing.size&"""  data="""&thing.name&""" pass="""" bs=""0"" icon=""iconaccess""/>"
				elseif sjkbs="-2147217843" then
					text.add "<access title="""&thing.name&" "&text.gettxt(15)&""" size="""&thing.size&"""  data="""&thing.name&""" pass="""" bs=""1"" icon=""iconaccess""/>"
				end if
			end if
		end if
	next  
	text.Completed
	if j=0 then
		text.infoshow mululj&" 目录下未发现数据库，请确认数据库地址设置","数据库目录提示"
	end if
end sub
sub gettable(ByVal a,ByVal b)
	On Error resume next
	dim conn,cat,tbl,fso,fsoml,bs,title
	set cat = server.CreateObject(COArray(2))
	set tbl= server.CreateObject(COArray(3))
	Set fso = Server.CreateObject(COArray(9))
	Set fsoml= fso.GetFile(mululj&"/"&a)
	call connaccess(conn,b,a)
	set cat.ActiveConnection = conn
	text.Start
	text.categoties "tablename"
	bs="0"
	title=a
	if len(b)>0 then
		bs="1"
		title=a&" "&text.gettxt(15)
	end if
	text.add "<access title="""&title&""" bs="""&bs&""" pass="""&b&""" size="""&fsoml.size&""" data="""&a&""" ReclaimedSpace="""&conn.Properties("Jet OLEDB:Compact Reclaimed Space Amount").Value&""" LocaleIdentifier="""&conn.Properties("Locale Identifier").Value&""" accesstype="""&conn.Properties("Jet OLEDB:Engine Type")&""">"
	for each tbl in cat.Tables
		if tbl.type = "TABLE" then
			text.add "<table access="""&a&""" pass="""&b&""" title="""&tbl.name&""" icon=""icontable""/>"
		end if 
	next
	text.add "</access>"
	text.Completed
	if err.number<>0 then
		if err.number=3709 then
			text.outerr text.gettxt(16)
		else
			text.outerr err.Description&","&err.number
		end if
	end if
end sub
sub getdatalist(ByVal a,ByVal b,ByVal c,ByVal d,ByVal pass)
	dim j,conn,rs,sql,i
	j=0
	call connaccess(conn,b,a)
	set rs=server.createobject(COArray(1))
	sql="select * from ["&b&"]"
	rs.open sql,conn,3,3
	rs.pagesize=cint(c)
	text.start
	text.categoties "tabledata"
	text.xmladd a,"dataaccess"
	text.xmladd b,"tablename"
	text.xmladd d,"pagenow"
	text.xmladd pass,"dataaccesspass"
	text.xmladd rs.pageCount,"pageCount"
	text.xmladd rs.recordCount,"recordCount"
	for i=0 to rs.fields.count-1
		text.xmladd rs.fields(i).name,"fields"
	next
	if not (rs.eof or err) then rs.move (cint(d)-1)*cint(c)
	do while not (rs.eof or err)
		text.add "<data1>"
			text.xmladd rs.AbsolutePosition,"datashow"
			for i=0 to rs.fields.count-1
				select case rs.fields(i).type
					case 205
						if not isnull(rs(i)) then
							text.xmladd text.gettxt(12),"datashow"
						else
							text.xmladd "","datashow"
						end if
					case 128
						if not isnull(rs(i)) then
							text.xmladd text.gettxt(13),"datashow"
						else
							text.xmladd "","datashow"
						end if
					case 204
						if not isnull(rs(i)) then
							text.xmladd text.gettxt(14),"datashow"
						else
							text.xmladd "","datashow"
						end if
					case 203
						if len(rs(i))>100 then
							text.xmladd replace(left(rs(i),90)&"...",chr(13)&chr(10),""),"datashow"
						else
							text.xmladd rs(i),"datashow"
						end if
					case else
						text.xmladd rs(i),"datashow"
				end select
		next
		text.add "</data1>"
		j=j+1
		if j>=cint(c) then exit do
		rs.movenext
	loop
	text.Completed
end sub
sub deletedata(ByVal a,ByVal b,ByVal c,ByVal d,ByVal e,ByVal pass)
	dim conn,sql,rs,data,i
	call connaccess(conn,b,a)
	set rs=server.createobject(COArray(1))
	sql="select * from ["&b&"]"
	rs.open sql,conn,3,3
	data = split(e,"|")
	for i = 0 to ubound(data)
	rs.AbsolutePosition = cint(data(i))
	rs.delete
	next
	rs.close
	conn.close
	text.start
	text.categoties "editdataend"
	text.Completed
end sub
sub getdata(ByVal a,ByVal b,ByVal c,ByVal d,ByVal pass)
	dim conn,cat,rs,sql,i
	set cat = server.CreateObject(COArray(2))
	call connaccess(conn,b,a)
	set rs=server.createobject(COArray(1))
	sql="select * from ["&b&"]"
	rs.open sql,conn,3,3
	if d=0 then
		rs.AbsolutePosition = cint(c)
	end if
	set cat.ActiveConnection = conn
	text.start
	if d=0 then
		text.categoties "editdata"
	else
		text.categoties "getfields"
	end if
	text.xmladd c,"AbsolutePosition"
	for i=0 to rs.fields.count-1
		if rs.fields(i).type<>205 and rs.fields(i).type<>128 and rs.fields(i).type<>204 and cat.Tables(b).Columns(rs.fields(i).name).Properties("Autoincrement")=false then
			text.add "<datashow>"
			text.xmladd rs.fields(i).name,"name"