fun.asp

1、本网吧多媒体系统采用B/S结构

<!--#include file="config.asp"--><%
class kingcms
public ip,theme,language,fontsize,name'管理员
public lastdate'前台会员的最后一次访问时间,因为读写次数太多,单独列出来
public sitename,systemname,page,template,path,siteurl,systempath'系统属性 path:前台系统安装路径,inst系统所在的目录
private sitedescription,sitebottominfo,sitelink'系统属性
private odoc,oBox'对象及参数,oBox:inc/language.xml
public tdiff,checkerr,pop'验证错误,提示,管理员验证
public pid,rn,code'页数,每页显示数,编码
public data,length,plist,count,pagecount'link:分页的连接,如果不定义这个就不运行
public js'动态标签数组
public ispath'是否为后台，后台true，前台false。
public isdb'数据库类型  1:mssql 0:access
private grades'级别数组
public vip'是否为vip用户
public badlanguage,lockip
private switch,carry'贯通样式
public thisurl'当前url，如：http://www.kingcms.com

private sub class_initialize()
	dim scriptname'获得目录
	scriptname=request.servervariables("script_name")
	page=replace(scriptname,"\","/")
	page=lcase(right(page,len(page)-instrrev(page,"/")))
	systempath=left(scriptname,len(scriptname)-len(page)-1)
	systempath=right(systempath,len(systempath)-instrrev(systempath,"/"))

	'验证数据库连接
	on error resume next
	set conn=server.createobject("adodb.connection")
	conn.open objconn
	if err.number<>0 then
		Il"请验证数据库连接!"
		response.end()
	end if
	err.clear

	tdiff=timer()
	redim outer(-1,2)'外部模板,此为二维数组
	redim inside(-1,1)'内部模板,
	redim js(8,-1)'动态标签

	'初始化系统信息,必须有数据库的情况下才可以
	dim rs,idata,port,sql
	sql="sitename,siteurl,systempath"'15
	set rs=conn.execute("select "&sql&" from kingsystem where systemid=1;")
		if not rs.eof and not rs.bof then
			idata=rs.getrows()
			sitename=idata(0,0)
			systemname="asplove"
			siteurl=idata(1,0)	
			path=idata(2,0)
            name="Guest"
			
			ip=request.servervariables("http_x_forwarded_for")
			if ip="" then ip=request.servervariables("remote_addr")

			port=request.servervariables("server_port")
			if cstr(port)="80" then port="" else port=":"&port
			thisurl=l11(siteurl,"://","/")
			if len(thisurl)>0 then
				thisurl="http://"&thisurl&port
			else
				thisurl=siteurl&port
			end if
		else
			Il l1l(0)
		end if
	set rs=nothing
		'给Err赋值
		checkerr=true'如果变成了false,就无法打开save
		pop=0
		admincheck=false'关闭状态,如果通过认证过程就为true
	if lcase(systempath)=lcase(path) then
		ispath=false
	else
		ispath=true
	end if
	isdb=instr(objconn,"provider=SQLOLEDB.1;")
end sub



'head  *** ***  www.KingCMS.com  *** ***
public sub head(l1,l2)'登陆验证,如果验证通过,就调用头(l1:级别 l2:标题)
	if cstr(l1)<>"" then
		'后台验证及参数
		if ispath then
			theme="default"
			fontsize=12
			'验证		
			if cstr(l2)<>"" then		
				if cstr(l2)="0" then
					carry=false'微缩样式					
				else
					l1ll1 l2
					carry=true'标准样式
				end if
			end if			
		end if
	end if

	'公共参数
	pid=l1ll("pid",2):if cstr(pid)="" then pid=1
	rn=l1ll("rn",2):if cstr(rn)="" or cstr(rn)="0" then rn=20
	''if cdbl(rn)>cdbl(king_maxrn) then rn=king_maxrn
	code=l1ll("code",0):if cstr(code)="" then code=llll("code"):if code="" then code="utf-8"
	'if ll11(king_code,code)=false then call error("system/error")
	
	
end sub






'error  *** ***  www.KingCMS.com  *** ***
public sub error(l1)
	if ispath then
		response.clear
			head "0",l2
			dim slip
			Il"<div id=""b0"" class=""error"">"
			Il"<table class=""table""><tr class=""e""><td class=""c"" style=""height:100px;"">统计出错啦～～～～</td></tr></table>"
			Il"</div>"
		response.end
	end if
end sub

'open  *** ***  www.KingCMS.com  *** ***
public sub open(l1,l2,l3)'sql,连接地址,参数:0=不分页   'sql,pid(l2=pid)当前页数,pagesize(l3=rn)每页大小
	dim l4,rs
	if isdb=1 then l4=1 else l4=3
	length=-1
	set rs=server.createobject("adodb.recordset")
	rs.open l1,conn,1,l4
		count=rs.recordcount
		pagecount=int(count/rn):if pagecount<(count/rn) then pagecount=pagecount+1
		if len(l2)>2 then'如果地址不为空,就要分页
			plist=IlI(l2,pid,pagecount)
		end if
		if not rs.eof and not rs.bof then
			rs.move rn*(pid-1)
			if not rs.eof then
				if l3=0 then
					data=rs.getrows()
				else
					data=rs.getrows(rn)
				end if
				length=ubound(data,2)
			end if
		end if
	rs.close
	set rs=nothing
end sub


'lefte  *** ***  www.KingCMS.com  *** ***
public function lefte(l1,l2)
	dim l3,l4,i
	l3=len(l1):l4=0
	for i=1 to l3
		if abs(asc(mid(l1,i,1)))>255 or asc(mid(l1,i,1))=0 then
			l4=l4+2
		else
			l4=l4+1
		end if
		if l4>=cdbl(l2) then
			lefte=left(l1,i)
			if len(l1)>len(lefte) then lefte=lefte&".."
			exit for
		else
			lefte=l1
		end if
	next
end function





'gethtm  *** ***  www.KingCMS.com  *** ***
public function gethtm(l1,l2)
	on error resume next
	dim I1,l3,l4,l5
	l5=mid(l1,1,instr(8,l1,"/"))
	set I1=createobject("msxml2.xmlhttp")
		I1.open "get",l1,false
'		I1.setrequestheader "Content-Type","application/x-www-form-urlencoded"
		I1.setrequestheader "referer",l5
		I1.send
		if I1.readystate<>4 then exit function'文档已经解析完毕，客户端可以接受返回消息
		select case cstr(l2)
		case"0" gethtm=I1.responsetext		' 将返回消息作为text文档内容；
		case"1" gethtm=I1.responsebody		' 将返回消息作为HTML文档内容；
		case"2" gethtm=I1.responsexml			' 将返回消息视为XML文档，在服务器响应消息中含有XML数据时使用； 
		case"3" gethtm=I1.responsestream	' 将返回消息视为Stream对象 
		case"4"
			l3=I1.responsetext
			l4=match(l3,"(<meta ).+?(charset=)(.+?)"".{0,}?\>")
			l4=l11(l4,"charset=","""")'获得编码
			if len(l4)>0 then
			else
				l4=king_collcode
			end if
			if lcase(l4)="utf-8" then
				gethtm=l3
			else
				gethtm=bytes2bstr(I1.responsebody,l4)		' 将返回消息作为HTML文档内容；
			end if
		end select
	set I1=nothing
	if err.number<>0 then err.clear
end function

'manageurl  *** ***  www.KingCMS.com  *** ***
public function managepath(l1)
	dim port:port=request.servervariables("server_port")
	dim url:url=request.servervariables("url")
	url=left(url,instrrev(url,"/"))
	if cstr(port)="80" then url=url&l1 else url=":"&port&url&l1
	managepath="http://"&request.servervariables("server_name")&url
end function


'bytestobstr  *** ***  www.kingcms.com  *** ***
private function bytes2bstr(l1,l2)
	dim I1
	set I1=server.createobject(king_stm)
		I1.type=1
		I1.mode =3
		I1.open
		I1.write l1
		I1.position=0
		I1.type=2
		I1.charset=l2
		bytes2bstr=I1.readtext
		I1.close
	set I1=nothing
end function







'copyfile  *** ***  www.KingCMS.com  *** ***
public sub copyfile(l1,l2)
	on error resume next
	dim fs
	set fs=createobject(king_fso)
		fs.copyfile server.mappath(l1),server.mappath(l2)
	set fs=nothing
	if err.number<>0 then err.clear
end sub



'l1ll1  *** ***  www.KingCMS.com  *** ***
sub l1ll1(l1)
	dim l2,l3
	dim rs,i,menuid

	if cstr(l1)="0" then l1="Author - Asplove.Cn"
	Il"<!DOCTYPE html public ""-//W3C//DTD XHTML 1.0 Transitional//EN"" ""http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd""><html xmlns=""http://www.w3.org/1999/xhtml""><head><meta http-equiv=""Content-Type"" content=""text/html; charset=utf-8""><meta name=""Author"" content=""asplove.cn"" /><meta name=""WebSite"" content=""www.asplove.cn"" /><script language=""JavaScript"" src=""theme/"&theme&"/fun.js""></script><title>"&sitename&" | asplove统计</title><link href=""theme/"&theme&"/style.css"" rel=""stylesheet"" type=""text/css"" /><style type=""text/css""><!--"&vbcr&"*{font-size:"&fontsize&"px;}"&vbcr&"--></style></head><body>"
	Il"<div id=""main"">"
end sub





'robot  *** ***  www.KingCMS.com  *** ***
public function robot()
	dim I1,I2,l1,l2,l3,i,rs
	l2=false
	l1=request.servervariables("http_user_agent")
	I1=split(king_robots,chr(124))
	for i=0 to ubound(I1)
		I2=split(I1(i),"@")
		if instr(lcase(l1),lcase(I2(0)))>0 then
			l2=true:l3=I2(1):exit for
		end if
	next
	robot=l2
	if l2 and len(l3)>0 then'如果是爬虫,就更新爬虫信息
		set rs=conn.execute("select botid from kingbot where botname='"&l3&"';")
			if not rs.eof and not rs.bof then
				conn.execute "update kingbot set botdate='"&tnow&"' where botid="&rs(0)&";"
			else
				conn.execute "insert into kingbot (botname,botdate) values ('"&l3&"','"&tnow&"');"
			end if
			rs.close
		set rs=nothing
	end if
end function




'topen  *** ***  www.KingCMS.com  *** ***
public sub topen(l1)
	dim l2
	on error resume next
	l2="Provider=Microsoft.Jet.OLEDB.4.0;Data Source="&server.mappath(l1)'"db#collect/"&cofile
	set tconn=server.createobject("adodb.connection")
	tconn.open l2
	if err.number<>0 then king.error("system/error")
end sub


'tclose  *** ***  www.KingCMS.com  *** ***
public sub tclose()
	on error resume next
	if isobject(tconn) then
		tconn.close
		set tconn=nothing
	end if
end sub

end class
'endclass






'kingslip  *** ***  www.KingCMS.com  *** ***
class kingslip
	private k,p
	private sub class_initialize()
		k=0
		p=0
		Il"<div id=""slip"">"
	end sub