cls.asp

教师评估系统

<%@ LANGUAGE = VBScript CodePage = 936%>
<%
On Error Resume Next

Response.Charset = "gb2312"
Response.Addheader "Content-Type","text/html; charset=gb2312"
Response.Buffer = True   '开启缓冲区
Session.Timeout = 20

BBSPath="/bbs/"	'论坛路径，从根目录开始，以/结尾
Db = "Data/Wx.mdb" '数据库路径，相对于论坛路径
XmlPath="Xml/"		  'Xml文件夹路径，相对于论坛路径，以/结尾
Prefix="Wx"   '论坛缓存、Cookie前缀

IsSqlDataBase=0
SysVersion="7.8.0"
Connstr="Provider=Microsoft.Jet.OLEDB.4.0;Data Source="&Server.MapPath(BBSPath&Db)
SqlNowString="Now()"
SqlDateChar="#"
SqlChar="'"
IsSqlVer="Acc"

Set Conn=Server.CreateObject("ADODB.Connection")
Conn.open ConnStr
if Err Then
 Response.Write ""&IsSqlVer&"数据库连接出错，请检查连接字串。"
 Set Conn = Nothing
 err.Clear
 Response.end
end if
On Error GoTo 0

dim CookieUserName,IsUser,NewMessage,UserRoleID,BestRole
dim toptrue,TotalPage,PageCount,RankName,RankIconUrl,ForumTreeList,ForumsList
dim starttime,Onlinemany,regOnline
Set Rs = Server.CreateObject("ADODB.Recordset")
Set Rs1 = Server.CreateObject("ADODB.Recordset")
Set XMLDOM=Server.CreateObject("Microsoft.XMLDOM")
if Not IsDate(Cache("System")) Then CreateCache()
if Cookies("Themes")=Empty then CookiesAdd "Themes",Cache("DefaultStyle"),30

function Cache(name)
 Cache=Application(Prefix&name)
end function

function Cookies(name)
 Cookies=Request.Cookies(Prefix&name)
end function

function ChkNumeric(num)
 if Not IsNumeric(num) Then num=0
 ChkNumeric=int(num)
end Function

function HTMLEncode(str)
str=Trim(str)
str=Replace(str,chr(9),"")
str=Replace(str,chr(13),"")
str=Replace(str,chr(22),"")
str=Replace(str,chr(38),"&#38;")	'“&”
str=Replace(str,chr(32),"&#32;")	'“ ”
str=Replace(str,chr(34),"&#34;")	'“"”
str=Replace(str,chr(39),"&#39;")	'“'”
str=Replace(str,chr(42),"&#42;")	'“*”
str=Replace(str,chr(44),"&#44;")	'“,”
str=Replace(str,chr(59),"&#59;")	'“;”
str=Replace(str,chr(60),"&#60;")	'“<”
str=Replace(str,chr(62),"&#62;")	'“>”
str=Replace(str,chr(92),"&#92;")	'“\”
str=Replace(str,chr(45)&chr(45),"&#45;&#45;")	'“--”
str=Replace(str,chr(10),"<br />")
str=ReplaceText(str,"([&#])([a-z0-9]*)&#59;","$1$2;")
if Cache("BannedText")<>"" then str=ReplaceText(str,"("&Cache("BannedText")&")",string(len("&$1&"),"*"))
'if IsSqlDataBase=0 then
str=escape(str)
str=ReplaceText(str,"%u30([A-F][0-F])","&#x30$1;")
str=unescape(str)
'end if
HTMLEncode=str
end function

Function ReplaceText(fString,patrn,replStr)
Set regEx = New RegExp   	' 建立正则表达式
regEx.Pattern = patrn   ' 设置模式
regEx.IgnoreCase = True ' 设置是否区分大小写
regEx.Global = True     ' 设置全局可用性
ReplaceText = regEx.Replace(""&fString&"",""&replStr&"") ' 作替换
Set regEx=nothing
end Function

Function AppendNewAttribute(attributeName,attributeValue)
Set NewAttribute=XMLDOM.CreateNode("attribute",attributeName,"")
NewAttribute.Text=attributeValue
TempNode.SetAttributeNode NewAttribute
end Function

Function CacheRowsList(name,sql,Exp) 'Exp:sec
Last = Cache(name&"_Last")
if Last="" Or Exp < DateDiff("s",Last,Now()) Then
 Application.Lock
 CacheAdd name,GetRowsList(sql)
 CacheAdd name&"_Last",Now()
 Application.Unlock
end if
CacheRowsList = Cache(name)
end Function

Function GetRowsList(sql)
Set Rs2=Conn.Execute(sql)
if Not Rs2.Eof Then GetRowsList = Rs2.GetRows()
Rs2.Close
Set Rs2 = Nothing
end Function

sub CookiesAdd(Key,Value,Exp)
 Response.Cookies(Prefix&Key)=Value
 Response.Cookies(Prefix&Key).Path = Cache("CookiePath")
 Response.Cookies(Prefix&Key).Expires=date()+Exp
end sub

sub CacheAdd(Name,Value)
 Application.Lock()
 Application(Prefix&Name)=Value
 Application.UnLock()
end sub

sub CloseDataBase
 Conn.Close
 set Rs1=nothing
 set Rs=nothing
 set XMLDOM=nothing
 set Conn=nothing
 Response.end
end sub

CookieUserName=Cookies("UserName")
IsUser=False
NewMessage=0
Server.ScriptTimeOut=Cache("TimeOut")

if CookieUserName<>Empty then
Set Rs=Conn.Execute("select Userpass,NewMessage,UserRoleID from [WxUsers] where Username='"&CookieUserName&"'")
if Rs.Eof then
 CleanCookies()
 CookieUserName=Empty
Elseif Cookies("Userpass") <> Rs(0) then
 CleanCookies()
 CookieUserName=Empty
Else
 NewMessage=Rs(1)
 UserRoleID=Rs(2)
 IsUser=True
 if UserRoleID=2 or UserRoleID=1 then BestRole=1
end if
Rs.Close
end if

if Cache("SysDate")<>date() then UpStat 0,0,0
ii=0

if Cache("BannedIP")<>Empty then if instr("|"&Cache("BannedIP"),"|"&Request.ServerVariables("REMOTE_ADDR")&"")>0 Then Error 6,"<li>您的IP被禁止进入论坛</li>"
script_name=Lcase(Request.ServerVariables("script_name"))
if Request.ServerVariables("Request_method") = "POST" then
http_referer=Lcase(Request.ServerVariables("http_referer"))
if instr(""&http_referer&"","http://"&Request.ServerVariables("server_name")&"") = 0 and instr(script_name,"Login.asp")=0 then Error 6,"<li>发现来源错误"&http_referer&"</li><li>建议您关闭防火墙后再提交此信息</li>"
end if

function ContentEncode(str)
str=Replace(str,vbCrlf, "")
str=Replace(str,"\","&#92;")
str=Replace(str,"'","&#39;")
if XMLDOM.loadxml("<div>"&Replace(str,"&","&amp;")&"</div>") Then
str=checkXHTML(str)
Else 'Not XHtml
str=checkDHTML(str)
end if
if Cache("BannedText")<>"" then str=ReplaceText(str,"("&Cache("BannedText")&")",string(len("&$1&"),"*"))
ContentEncode=str
end function

Function checkDHTML(str)
str=Replace(str,"<A ","<a target=_blank ")
str=Replace(str,"<a ","<a target=_blank ")
if Cache("BannedHtmlLabel")<>"" then str=ReplaceText(str,"<(\/|)("&Cache("BannedHtmlLabel")&")", "&lt;$1$2")
if Cache("BannedHtmlEvent")<>"" then str=ReplaceText(str,"<(.[^>]*)("&Cache("BannedHtmlEvent")&")", "&lt;$1$2")
checkDHTML=str
end Function

Function checkXHTML(str)
for Each Node in XMLDOM.documentElement.getElementsByTagName("*")
NodeName = LCase(Node.nodeName)
NodeNameList= LCase("|"&Cache("BannedHtmlLabel")&"|")
if Instr(NodeNameList,"|"&NodeName&"|")>0 Then
Set newnode=XMLDOM.createTextNode(node.xml)
node.parentNode.replaceChild newnode,node
end if
if NodeName="a" Then Node.setAttribute "target","_blank"
if NodeName="style" Then Node.parentNode.removeChild(Node)
if NodeName="embed" Then Node.setAttribute "quality","high":Node.setAttribute "wmode","opaque"
For Each Attribute in node.attributes
AttName = LCase(Attribute.nodeName)
if Left(AttName,2) = "on" Then
node.removeAttribute AttName
Else
nodetext=replaceasc(Attribute.text)
if InStr(nodetext,"script:")>0 or InStr(nodetext,"document.")>0 Or InStr(nodetext,"xss:") > 0 Or InStr(nodetext,"expression") > 0 Then
node.removeAttribute AttName
end if 
end if
Next
Next
checkXHTML=Replace(Mid(XMLDOM.documentElement.xml,6,Len (XMLDOM.documentElement.xml)-11),"&amp;","&")
end Function

Function replaceasc(strText)
Dim s,match,po,i
Set re=New RegExp
s=Replace(strText,"&amp;","&")
if InStr(s,"\")=0 And InStr(s,"&#")=0 Then
replaceasc=LCase(strText)
Exit Function
end if
re.Pattern="(&#x)([0-9|a-z]{1,2})"
Set match = re.Execute(s)
For i= 0 to  match.count -1
po=re.Replace(match.item(i),"$2")
po="&H"+po
if IsNumeric(po) Then
s=Replace(s,match.item(i),chr(po))
end if
Next
re.Pattern="(&#0*)"
s=re.Replace(s,"&#")
re.Pattern="&#([0-9]{1,3})"
Set match = re.Execute(s)
For i= 0 to  match.count -1
po=re.Replace(match.item(i),"$1")
s=Replace(s,"&#"&po&";",chr(po))
s=Replace(s,"&#"&po&"",chr(po))
Next
re.Pattern="(\\0*)"
s=re.Replace(s,"\")
re.Pattern="(\\)([0-9|a-z]{1,2})"
Set match = re.Execute(s)
For i= 0 to  match.count -1
po=re.Replace(match.item(i),"$2")
po="&H"+po
if IsNumeric(po) Then
s=Replace(s,match.item(i),chr(po))
end if
Next
s=Replace(s,chr(13),"")
s=Replace(s,chr(10),"")
s=Replace(s,chr(9),"")
s=Replace(s,"/*","")
s=Replace(s,"*/","")
replaceasc=LCase(Replace(s,chr(0),""))
Set re=Nothing
end Function

function YbbEncode(str)
if instr(str,"[")=0 or instr(str,"]")=0 then
 YbbEncode=str
 exit function
end if
str=ReplaceText(str,"\[(\/|)(b|i|u|strike|center|marquee)\]","<$1$2>")
str=ReplaceText(str,"\[COLOR=([^[]*)\]","<font COLOR=$1>")
str=ReplaceText(str,"\[FONT=([^[]*)\]","<font face=$1>")
str=ReplaceText(str,"\[SIZE=([0-9]*)\]","<font size=$1>")
str=ReplaceText(str,"\[\/(SIZE|FONT|COLOR)\]","</font>")
str=ReplaceText(str,"\[URL\]([^[]*)","<a target=_blank href=$1>$1")
str=ReplaceText(str,"\[URL=([^[]*)\]","<a target=_blank href=$1>")
str=ReplaceText(str,"\[\/URL\]","</A>")
str=ReplaceText(str,"\[EMAIL\](\S+\@[^[]*)(\[\/EMAIL\])","<a href=mailto:$1>$1</a>")
str=ReplaceText(str,"\[IMG\]([^"&chr(34)&"[]*)(\[\/IMG\])","<img src=$1>")
str=ReplaceText(str,"\[quote\]","<blockquote>")
str=ReplaceText(str,"\[quote user="&chr(34)&"([^[]*)"&chr(34)&"\]","<blockquote><img src=Images/icon-quote.gif /> <b>$1:</b><br />")
str=ReplaceText(str,"\[\/quote\]","</blockquote>")
YbbEncode=str
end function