<%
Call tostopip(2)'判断是否开放浏览
Dim time1
time1=Timer()

''''''''''''''''''''''''''''''''''''''
'找出系统管理员 
''''''''''''''''''''''''''''''''''''''
Dim sysManager'定义系统管理员
Dim sm_arr,sm_i
'sysManager = Replace(bbsbanzhu,"|"," ")
sm_arr = Split(bbsbanzhu,"|")
sysManager = "<select name='sysManager' class='selBoardManager'>"&vbCrlf
for sm_i = 0 to Ubound(sm_arr)
	sysManager = sysManager &"<option value='"&sm_arr(sm_i)&"'>"&sm_arr(sm_i)&"</option>" & vbCrlf
Next
sysManager = sysManager&"</select>" & vbCrlf


'*************************************
'定义是否登陆
'*************************************
'判断用户是否版主
Dim IsAdmin
IsAdmin =0
If Dreamsun_name<>"" Then 
	cbz=split(bbsbanzhu,"|")
	For cbzi=0 To Ubound(cbz)
		If Dreamsun_name=cbz(cbzi) Then
			isadmin = 9 '超级管理员
		End If 
	Next
End If 
Sub checkuser()
	If DreamSun_name="" Then
		Response.Write backmsg("对不起，您尚未登录，不能使用该功能！","user.asp")
	End If 
End Sub 
'*************************************
'信息网 专用页码简化版,取得显示页码
'*************************************
function viewpage(p_c,p_n,p_x,p_p,Dreamsun_cls,p_z,showfile)
         '总记录,显示记录数,显示页数,当前页,传替参数,总数说明,当前页面名称
         dim p_k,p_y,p_p2,p_p3,p_m
         '计算页数相关
 		 if p_c/p_n = int(p_c/p_n) then 
		 p_y=int(p_c/p_n)
		 else
		 p_y=int(p_c/p_n)+1
		 end if
         if p_p>p_y then p_p=p_y  
         p_p2= int(p_p/p_x)
		 if p_p/p_x>p_p2 then p_p2=p_p2+1
		 p_k=p_p2*p_x
		 if p_k>p_y then p_k=p_y               
			   viewpage=viewpage& "<form name='formpage' method='post' action='"&showfile&"?"&Dreamsun_cls&"' style='margin-bottom:0;margin-top:0'>"& vbCrLf
			   viewpage=viewpage& p_z & p_c &" 每页"&p_n&"条  当前"& p_p &"/"& p_y &"页 "
               if p_p2>1 then
               viewpage=viewpage& "<a href='"&showfile&"?CurPage=1&"&Dreamsun_cls&"'>首页</a>"
               viewpage=viewpage& " <a href='"&showfile&"?CurPage="& p_p2*p_x-p_x &"&"&Dreamsun_cls&"'>上一翻页</a>"
               end if
               For p_m =p_p2*p_x-(p_x-1) To p_k
               if p_m=p_p then
               viewpage=viewpage& " [<a href='"&showfile&"?CurPage="& p_m &"&"&Dreamsun_cls&"'><font color=#ff0000>"& p_m &"</font></a>]"
			   else
               viewpage=viewpage& " [<a href='"&showfile&"?CurPage="& p_m &"&"&Dreamsun_cls&"'>"& p_m &"</a>]"
               end if
			   Next
               if p_p2*p_x < p_y then
               viewpage=viewpage& " <a href='"&showfile&"?CurPage="&p_m&"&"&Dreamsun_cls&"'>下一翻页</a>"
	           viewpage=viewpage& " <a href='"&showfile&"?CurPage="&p_y&"&"&Dreamsun_cls&"'>尾页</a>"
               end if

			   viewpage=viewpage& "&nbsp;<input name='CurPage' type='text' value='"& p_p &"' size='2' maxlength='5' onKeyPress=""if ((event.keyCode<48 || event.keyCode>57)) event.returnValue=false"">&nbsp;<input  type='submit' name='Submit' value='go'></form>"& vbCrLf

End Function
'*************************************
'返回信息定向函数
'*************************************
Function backmsg(msg,url)
	If url="" Then 
		Response.Write "<script>alert('"&msg&"');history.back();</Script>"
		Response.End
	Else 
		If msg="" Then 
			Response.Redirect url
		else
			Response.Write "<script>alert('"&msg&"');window.location.replace('"&url&"');</Script>"
			Response.End
		End If
	End If
end Function
'*************************************
'汉字截取函数,将汉字计算为两个字符
'*************************************
Function TitleLeft(str,strlen)	
	Dim l,t,c, i
	l=len(str)
	t=0
	For i=1 to l
		c=Abs(Asc(Mid(str,i,1)))
	If c>255 then
		t=t+2
	Else
		t=t+1
	End if
	If t>=strlen then
		TitleLeft=left(str,i)&".."
		Exit for
	Else
		TitleLeft=str&""
	End If
	Next
End Function
'*************************************
'定义搜索区域
'*************************************
Sub bbssearch()
	Select Case act'人性化设计，让搜索显示的时候，自动记录这个搜索的类型
		Case ""
			sobt="checked"
		Case "title"
			sobt="checked"
		Case "username"
			sozz="checked"
		Case "content"
			sonr="checked"
	End Select
If allreplies=1 Then sonre="checked" 
response.write"<form name=""form1"" method=""get"" action=""index.asp"" style=""margin:5px;"">"& vbCrLf
response.write"	  <input class=searchinput name=""keys"" type=""text"" id=""keys"" value="""&keys&""" size=""15"" maxlength=""10"">"& vbCrLf
response.write"      <input class=searchsubmit type=""submit"" value=""搜索"">"& vbCrLf
response.write"      <input class=searchwukuang name=""act"" type=""radio"" value=""title"" "&sobt&" id=""i_title""><label for=i_title>标题</label>"& vbCrLf
response.write"<input class=searchwukuang type=""radio"" name=""act"" value=""username"" "&sozz&" id=""i_username""><label for=i_username>作者</label>"& vbCrLf
response.write"<input class=searchwukuang type=""radio"" name=""act"" value=""content"" "&sonr&" id=""i_content""><label for=i_content>内容</label>"& vbCrLf
response.write"<input class=searchwukuang type=""checkbox"" name=""allreplies"" value=""1"" "&sonre&" id=""i_allreplies""><label for=i_allreplies>含回复</label>"& vbCrLf
response.write"    </form>"& vbCrLf
End Sub 
'*************************************
'定义快捷登陆区域
'*************************************
Sub bbslogin()
if Dreamsun_name= "" then
	response.write"<A href='user.asp'>登录</A> | <A href='user.asp?Action=reg'>注册</A> | <a href='user.asp?Action=restorePwd' title='按此找回密码'>忘记密码?</a>"
Else
	mes = LCase(Dreamsun_name)
	level = AdminLevel(CStr(mes))
	Select Case level
		Case 0
			mes = "<font style='cursor:wait;' title='普通会员'>" & mes & "</font>"
		Case 1
			mes = "<font style='cursor:crosshair;' title='分版主' color="&boardManagerColor&">" & mes & "</font>"
		Case 9
			mes = "<font style='cursor:hand;' title='系统管理员' color="&superManagerColor&">" & mes & "</font>"
	End Select 
	response.write "欢迎 " & mes &" | <A href='user.asp?Action=modifypassword'>我的</A> | <A href='usersms.asp'>消息</A> "
	rss=conn.execute("Select Count(id) from message where incept='"&Dreamsun_name&"' and issend=1 and flag=0 and delR=0")
	getmm=rss(0)
	if isnull(getmm) then getmm=0
	If getmm>0 Then response.write "(<font color=red>"&rss(0)&"</font>)"
	If level>0 Then
		Response.Write(" | <a href='user.asp?Action=GM'>团队</a> ")
	End If 
	response.write "| "
	'Edit At 2007-11-13 CHANG,ZIDONE
	If CInt(isadmin)=9 Then response.write ""
	response.write " <A href='user.asp?Action=exit'>退出</A>"
end if
End Sub 
'*************************************
'定义是否登陆
'*************************************
Sub checkuser()
	If DreamSun_name="" Then
			Response.Write("<script>alert(""对不起，您无权访问该页面"");window.history.back();</script>")
	response.end
	End If 
End Sub 
'*************************************
'定义是不是管理员
'*************************************
Sub checkadmin()
	If isadmin<>9 Then
			Response.Write("<script>alert(""对不起，您不是管理员，请不要恶意操作"");window.close();</script>")
			response.end
	End If 
End Sub 
'*************************************
'定义是否为斑竹
'*************************************
Sub checkbanzhu()
	If Dreamsun_name<>"" Then 
		Set rs_bn4 = Server.CreateObject("ADODB.Recordset") 
			sql_bn4="select board_admin from "&boardtable&" where board_id="&boardid
			rs_bn4.open sql_bn4,conn,1,1 
				if Not rs_bn4.eof Then
					boardadmin0=rs_bn4(0)
				End If 
			rs_bn4.close
		Set rs_bn4=Nothing
		bz=split(boardadmin0,"|")
			for ti=0 to ubound(bz)
				If Dreamsun_name=bz(ti) Then isadmin=1
			Next
	'If isadmin<>1 Then
	If isadmin<1 Then
			Response.Write("<script>alert(""对不起，您不是该版管理员，请不咨询管理员"");window.location='./';</script>")
			response.end
	End If
else
			Response.Write("<script>alert(""对不起，登陆信息丢失"");window.location='./';</script>")
			response.end
	End If 
End Sub 
'*************************************
'个性签名函数
'*************************************
Function sigline(username0)
If username0="" Then Exit function
Set rs5= Server.CreateObject("ADODB.Recordset")
	sql5="select user_show from "&usertable&" where username='"&username0&"'"
	rs5.Open sql5, conn,3,3
		If rs5.eof And rs5.bof Then 
		Else
			user_show=rs5("user_show")
		End If 
	If user_show<>"" Then 
%>               
<div class="sigline"><span class=siglinenote>个性签名</span></div>
<div class="siglinetext"><%=DropFuckWords(ubbs(user_show))%></div>
<%
	rs5.close
Set rs5=Nothing
End If
End Function 
'*************************************
'定义贴吧的分类
'board_name,board_id,board_about,board_admin 
'0             1       2              3
'*************************************
Sub boardlist()
Dim kkk
listid=listid&"<TABLE cellSpacing=1 cellPadding=0 border=0 >"& vbCrLf
listid=listid&"        <TBODY>"& vbCrLf
listid=listid&"        <TR align=middle >"& vbCrLf
tr=1
hang=1
		if ubound(Arr_Category,1)=0 then Response.Write("<td>还没有贴吧</td>"):exit Sub
		Category_Len=ubound(Arr_Category,2)
		For kkk=0 To Category_Len
				'开始循环
				If boardid=int(Arr_Category(1,kkk)) Then
				bn="<b>"&Arr_Category(0,kkk)&"</b>"
				Else 
				bn=Arr_Category(0,kkk)
				End If 
				listid=listid&"<TD height=26 align=center  width=90> <A href=""index.asp?boardid="&Arr_Category(1,kkk)&""" title="""&Arr_Category(0,kkk)&""">"&bn&" | </A> </TD>"& vbCrLf
				tr=tr+1'方格子个数加1
				if tr > boardtr Then'如果方格子大于了规定的换行数
					listid=listid&"</tr><TR align=middle class=""zd_td"">"'输出换行
					hang=hang+1'行数加1，为的是不至于在一行上如果达不到规定的方格子数而补齐出现空白
					tr=1'方格子重新计数，从1开始
				End If
			Next
			listid=listid&"<TD height=22 width=60 align=center><A href=""index.asp?boardid=0"">全部分类</A></TD>"& vbCrLf
			if tr<boardtr And hang>1 then'如果方格子数目小于规定换行数且多于一行，就要用空行补齐，免得出现错位。
				for m=tr to boardtr-1'开始循环，之所以到规定数目-1，是因为上面手工添加了一个单元格 全部分类。否则会出现多一个的问题
					listid=listid&"<td height=22 align=center> </td>"
				next
			end if'补齐判断结束
Response.Write(listid)'输出分类列表单元格。
Response.Write("</TR></TBODY></TABLE>")
End Sub 
'*************************************
'定义贴吧分类选单
'*************************************
Sub boardselect()
Dim ksel
	Response.Write("<select name=""boardid"" id=""boardid"">"&Chr(13)&Chr(10))
	if ubound(Arr_Category,1)=0 then Response.Write("<option>还没有贴吧</option></select>"):exit Sub
	Category_Len=ubound(Arr_Category,2)
	listids = listids&"<option value=''>请选择贴吧</option>"&Chr(13)&Chr(10)
		For ksel=0 To Category_Len
			listids=listids&"<Option value="&Arr_Category(1,ksel)&">"&Arr_Category(0,ksel)&"</option>"&Chr(13)&Chr(10)
		Next
	Response.Write(listids)
	Response.Write("</select>")
End Sub 
'*************************************
'过滤超链接
'*************************************
Function checkURL(ByVal ChkStr)
	Dim str:str=ChkStr
	str=Trim(str)
	If IsNull(str) Then
		checkURL = ""
		Exit Function 
	End If
	Dim re
	Set re=new RegExp
	re.IgnoreCase =True
	re.Global=True
	re.Pattern="(d)(ocument\.cookie)"
    Str = re.replace(Str,"$1ocument cookie")
	re.Pattern="(d)(ocument\.write)"
    Str = re.replace(Str,"$1ocument write")
   	re.Pattern="(s)(cript:)"
    Str = re.replace(Str,"$1cri&#112;t ")
   	re.Pattern="(s)(cript)"
    Str = re.replace(Str,"$1cri&#112;t")
   	re.Pattern="(o)(bject)"
    Str = re.replace(Str,"$1bj&#101;ct")
   	re.Pattern="(a)(pplet)"
    Str = re.replace(Str,"$1ppl&#101;t")
   	re.Pattern="(e)(mbed)"
    Str = re.replace(Str,"$1mb&#101;d")
	Set re=Nothing
   	Str = Replace(Str, ">", "&gt;")
	Str = Replace(Str, "<", "&lt;")
	checkURL=Str    
end function


'*************************************
'过滤单引号
'Atrribute Add For V1.5 2007-11-11 CHANG,ZIDONE
'*************************************
function ClearString(str)
	' 单引号
	while instr(str,"'")>0
		str =Replace(str,"'","")
	wend
	' 空格
	str = trim(str)
	' 其他
	ClearString=str
end function
'*************************************
'输出JS
'Atrribute Add For V1.5 2007-11-11 CHANG,ZIDONE
'*************************************
function SetJS(str)
	SetJS = "<script language='javascript'>"&str&"</script>"
end function
function SetJSAlert(str)
	SetJSAlert = "<script language='javascript'>alert('"&str&"');</script>"
end Function

Dim regEx
  Set regEx = New RegExp
  regEx.Pattern = "(<[^>]*?>)"
  regEx.Global = True
  regEx.IgnoreCase = True
'*************************************
'UBB函数
'*************************************
function UBBs(Content)
	Content = HTMLcode(Content)
dim re
Set re=new RegExp
re.IgnoreCase =true
re.Global=True
	
	re.Pattern="(javascript)"
	Content=re.Replace(Content,"&#106avascript")
	re.Pattern="(jscript:)"
	Content=re.Replace(Content,"&#106script:")
	re.Pattern="(js:)"
	Content=re.Replace(Content,"&#106s:")
	re.Pattern="(value)"
	Content=re.Replace(Content,"&#118alue")
	re.Pattern="(about:)"
	Content=re.Replace(Content,"about&#58")
	re.Pattern="(file:)"
	Content=re.Replace(Content,"file&#58")
	re.Pattern="(document.cookie)"
	Content=re.Replace(Content,"documents&#46cookie")
	re.Pattern="(vbscript:)"
	Content=re.Replace(Content,"&#118bscript:")
	re.Pattern="(vbs:)"
	Content=re.Replace(Content,"&#118bs:")
	re.Pattern="(on(mouse|exit|error|click|key))"
	Content=re.Replace(Content,"&#111n$2")


'-----------自动识别URL标签----------------
If 1=2 Then '1=2?纯粹的不可能，就是为了关闭这个标签。如果要打开，请让1=1
			re.Pattern="([^=\]][\s]*?|^)(http|https|rstp|ftp|mms|ed2k)://([A-Za-z0-9\.\/=\?%\-_~`@':+!]*)"
			Set strMatchs=re.Execute(Content)
			For Each strMatch in strMatchs
				tmpStr1=strMatch.SubMatches(0)
				tmpStr2=strMatch.SubMatches(1)
				tmpStr3=checkURL(strMatch.SubMatches(2))
				Content=replace(Content,strMatch.Value,tmpStr1&"<a href="""&tmpStr2&"://"&tmpStr3&""" target=""_blank"">"&tmpStr2&"://"&tmpStr3&"</a>",1,-1,0)
			Next
End If 
'-----------多媒体标签----------------
	re.Pattern="\[(swf|wma|wmv|rm|mp3)(=\d*?|)(,\d*?|)\]([^<>]*?)\[\/(swf|wma|wmv|rm|mp3)\]"
      Set strMatchs=re.Execute(Content)
      dim strType,strWidth,strHeight,strSRC,TitleText
		For Each strMatch in strMatchs
			RAndomize
			  strType=strMatch.SubMatches(0)
			  if strType="swf" then
			   TitleText="<img src=""images/flash.gif"" alt="""" style=""margin:0px 2px -3px 0px"" border=""0""/>Flash动画"
			  elseif strType="wma" or strType="mp3"then
			   TitleText="<img src=""images/music.gif"" alt="""" style=""margin:0px 2px -3px 0px"" border=""0""/>播放音频文件"
			  elseif strType="wmv" then
			   TitleText="<img src=""images/mediaplayer.gif"" alt="""" style=""margin:0px 2px -3px 0px"" border=""0""/>播放视频文件"		 
			  elseif strType="rm" then
			   TitleText="<img src=""images/realplayer.gif"" alt="""" style=""margin:0px 2px -3px 0px"" border=""0""/>播放real视频流文件"		 
			  end if
              strWidth=strMatch.SubMatches(1)
              strHeight=strMatch.SubMatches(2)
              if (len(strWidth)=0) then 
                strWidth="400"
                else
               strWidth=right(strWidth,(len(strWidth)-1))
              end if
              if (len(strHeight)=0) then
               strHeight="300"
                else
              strHeight=right(strHeight,(len(strHeight)-1))
              end if
              strSRC=checkURL(strMatch.SubMatches(3))
			rndID="temp"&Int(100000 * Rnd)
			Content= Replace(Content,strMatch.Value,"<div><div class=""code_head"">"&TitleText&"</div><div  class=""code_main""><a id="""+rndID+"_href"" href=""javascript:MediaShow('"+strType+"','"+rndID+"','"+strSRC+"','"+strWidth+"','"+strHeight+"')""><img name="""+rndID+"_img"" src=""images/mm_snd.gif"" style=""margin:0px 3px -2px 0px"" border=""0"" alt=""""/><span id="""+rndID+"_text"">在线播放</span></a><div id="""+rndID+"""></div></div></div>")
		Next
		Set strMatchs=nothing

'-----------普通标签----------------
	re.Pattern="\[IMG\](.[^\[]*)(\[\/IMG\])"
	Content = re.Replace(Content,"<font color=red>插图:</font><div class='cimg'><img src='$1' border='0' onmouseover=""this.style.cursor='hand';"" onclick=""window.open(this.src);"" ></div><br>")
	
	re.Pattern = "\[url=(.[^\]]*)\](.[^\[]*)\[\/url]" 
	Set strMatchs=re.Execute(Content)
	For Each strMatch in strMatchs
		tmpStr1=checkURL(strMatch.SubMatches(0))
		tmpStr2=strMatch.SubMatches(1)
		Content=replace(Content,strMatch.Value,"<a target=""_blank"" href="""&tmpStr1&""">"&tmpStr2&"</a>",1,-1,0)
	Next

	re.Pattern = "\[url](.[^\[]*)\[\/url]"
	Set strMatchs=re.Execute(Content)
	For Each strMatch in strMatchs
		tmpStr1=checkURL(strMatch.SubMatches(0))
		Content=replace(Content,strMatch.Value,"<a target=""_blank"" href="""&tmpStr1&""">"&tmpStr1&"</a>",1,-1,0)
	Next
	re.Pattern="\[hidden\](.*?)\[\/hidden\]"
	if len(Dreamsun_name)>0 then		
		Content= re.Replace(Content,"<div class=""code_head"">显示被隐藏内容</div><div class=""code_main"">$1</div>")
	else
		Content= re.Replace(Content,"<div class=""code_head"">隐藏内容</div><div class=""code_main"">该内容已经被作者隐藏,只有会员才允许查阅 <a href=""user.asp"">登录</a> | <a href=""user.asp?action=reg"">注册</a></div>")
	end if
	re.Pattern="\[align=(\w{4,6})\]([^\r]*?)\[\/align\]"
	Content=re.Replace(Content,"<div align=""$1"">$2</div>")
	re.Pattern="\[color=(#\w{3,10}|\w{3,10})\]([^\r]*?)\[\/color\]"
	Content=re.Replace(Content,"<span style=""color:$1"">$2</span>")
	re.Pattern="\[size=(\d{1,2})\]([^\r]*?)\[\/size\]"
	Content=re.Replace(Content,"<span style=""font-size:$1px"">$2</span>")
	re.Pattern="\[font=([^\r]*?)\]([^\r]*?)\[\/font\]"
	Content=re.Replace(Content,"<span style=""font-family:$1"">$2</span>")
	re.Pattern="\[b\]([^\r]*?)\[\/b\]"
	Content=re.Replace(Content,"<strong>$1</strong>")
	re.Pattern="\[i\]([^\r]*?)\[\/i\]"
	Content=re.Replace(Content,"<i>$1</i>")
    re.Pattern="\[u\]([^\r]*?)\[\/u\]"
	Content=re.Replace(Content,"<u>$1</u>")
	re.Pattern="\[QUOTE\](.[^\[]*)\[\/QUOTE\]"
	Content= re.Replace(Content,"<div class=""code_head"" style=""float:left"">引用或者代码:</div><br><div class=""code_main"">$1</div>")
	re.Pattern="\[html\](.*?)\[\/html\]"
	Set strMatchs=re.Execute(Content)
	For Each strMatch in strMatchs
		RAndomize
			RNDStr=Int(7999 * Rnd + 2000)
			tmpStr1=strMatch.SubMatches(0)
			Content= Replace(Content,strMatch.Value,"<div class=""code_head"" style=""float:left"">HTML代码:</div><div class=""code_head"" style=""float:right""><a href=""javascript:CopyText(document.all.CODE_"&RNDStr&");"">[ 复制代码 ]</a> <a href=""javascript:runCode(document.all.CODE_"&RNDStr&");"">[ 运行代码 ]</a></div><br><div class=""code_main"" id=""CODE_"&RNDStr&""" style=""overflow-y:auto;overflow-x:hidden;height:200px;"">"&tmpStr1&"</div>")
	Next
	re.Pattern="\{:em*([0-9]*)}"
	Content=re.Replace(Content,"<img border='0' src=images/ubb/em$1.gif>")

set re=Nothing
UBBs=Content
end function
'*************************************
'HTML代码转换
'*************************************
function HTMLcode(Content)
	if not isnull(Content) then
		Content = Replace(Content, "  ","&nbsp;&nbsp;")
		Content = Replace(Content, ">", "&gt;")
		Content = Replace(Content, "<", "&lt;")
		Content = Replace(Content, "\", "\\")
		Content = Replace(Content, CHR(34), "&quot;")
		Content = Replace(Content, CHR(39), "&#39;")
		Content = Replace(Content, CHR(13), "")
		Content = Replace(Content, CHR(10) & CHR(10), "</P><P> ")
		Content = Replace(Content, CHR(10), "<BR>")
		HTMLcode = Content
	end if
end Function
'*************************************
'过滤textarea
'*************************************
Function UBBFilter(ByVal reString)
	Dim Str:Str=reString
	If Not IsNull(Str) Then
		Str = Replace(Str, "</textarea>", "<&#47textarea>")
		UBBFilter = Str
	End If
End Function
'*************************************
'反转换HTML代码
'*************************************
Function HTMLDecode(ByVal reString) 
	Dim Str:Str=reString
	If Not IsNull(Str) Then
		Str = Replace(Str, "&gt;", ">")
		Str = Replace(Str, "&lt;", "<")
		Str = Replace(Str, "&#160;&#160;&#160;&#160;", CHR(9))
	    Str = Replace(Str, "&nbsp;", CHR(32))
		Str = Replace(Str, "&#39;", CHR(39))
		Str = Replace(Str, "&quot;", CHR(34))
		Str = Replace(Str, "", CHR(13))
		Str = Replace(Str, "<br/>", CHR(10))
		HTMLDecode = Str
	End If
End Function

'*************************************
'JS代码转换
'*************************************
Function FilterJS(v)
	if not isnull(v) then
		dim t
		dim re
		dim reContent
		Set re=new RegExp
		re.IgnoreCase =true
		re.Global=True
		re.Pattern="(javascript)"
		t=re.Replace(v,"&#106avascript")
		re.Pattern="(jscript:)"
		t=re.Replace(t,"&#106script:")
		re.Pattern="(js:)"
		t=re.Replace(t,"&#106s:")
		re.Pattern="(value)"
		t=re.Replace(t,"&#118alue")
		re.Pattern="(about:)"
		t=re.Replace(t,"about&#58")
		re.Pattern="(file:)"
		t=re.Replace(t,"file&#58")
		re.Pattern="(document.cookie)"
		t=re.Replace(t,"documents&#46cookie")
		re.Pattern="(vbscript:)"
		t=re.Replace(t,"&#118bscript:")
		re.Pattern="(vbs:)"
		t=re.Replace(t,"&#118bs:")
		re.Pattern="(on(mouse|exit|error|click|key))"
		t=re.Replace(t,"&#111n$2")
		re.Pattern="(&#)"
		t=re.Replace(t,"＆#")
		FilterJS=t
		set re=nothing
	end if
End Function



function formatQueryStr(str) '格式化sql中的like字符串
dim nstr
nstr = str
nstr = replace(nstr,chr(0),"")
nstr = replace(nstr," ","")
nstr = replace(nstr,"，","")
nstr = replace(nstr,"+","")
formatQueryStr = nstr
end function

' IP算法
function cip(sip)
         dim tip
		 tip = split(sip,".") 
		  if not IsArray(tip) then call backerr("错误的IP")
          if UBound(tip)<3 then call  backerr("错误的IP")
          if Not IsNumeric(tip(0)) or  Not IsNumeric(tip(1)) or  Not IsNumeric(tip(2)) or Not IsNumeric(tip(3)) then call backerr("错误的IP")
		  if cint(tip(0))>255 or cint(tip(1))>255 or cint(tip(2))>255 or cint(tip(3))>255 then call backerr("错误的IP")
	if cint(tip(0))<128 then
		cip=cint(tip(0))*256*256*256+cint(tip(1))*256*256+cint(tip(2))*256+cint(tip(3))
	else
		cip=cint(tip(0))*256*256*256+cint(tip(1))*256*256+cint(tip(2))*256+cint(tip(3))-4294967296
	end if
end Function

sub tostopip(str)

    dim u_ip
	u_ip=reip()

	if InStr(u_ip,".")=0 then
		Response.write"您所在的IP地址已经被暂时不允许使用本站点<br />"
		Response.end
	end if

	realIP = u_ip
	u_ip=cip(u_ip)
	'ar1= Split(realIP)(0)&Split(realIP)(1) 
	ar2= Split(realIP,".")(0) &"." & Split(realIP,".")(1) &"." & Split(realIP,".")(2) 
	if not conn.execute("select viw From stopip where viw="&str&" and ("& u_ip &" between oneip and endip)",0,1).eof then 

		Select Case (str) 
			Case 1
			Response.write backmsg("您所在的IP地址已经被暂时不允许注册新用户","")
			case 2
			conn.close
			set conn=nothing
			Response.write backmsg("您所在的IP地址已经被暂时不允许使用本站点","")
			Response.End()
			Case Else
		End Select
	Else
		sql = "select ip1,viw from stopip where ip1 like '"& ar2 &"%'"
		Set rs = Server.CreateObject("ADODB.Recordset")
		rs.open sql,conn,1,1
		While Not rs.eof 
			If Split(CStr(rs("ip1")),".")(3)="*"  Then
				If (CInt(rs("viw")) = 2 And str = 2) Then 
					Response.write backmsg("您所在的IP地址已经被暂时不允许使用本站点","")
					Response.End()
				ElseIf (CInt(rs("viw")) = 1 and str = 1) Then
					Response.Write("<script>alert('您所在的IP地址已经被暂时不允许注册新用户');</script>")
					Response.End()
					
				End If 
			End If 
			rs.movenext
		Wend 

	end if
End Sub
'*************************************
'获取用户的IP
'*************************************
Function reip()
reip = Request.ServerVariables("HTTP_X_FORWARDED_FOR") 
If reip = "" Then reip = Request.ServerVariables("REMOTE_ADDR")
End Function
'*************************************
'生成随机数
'*************************************
Function dreamsun_rnd(str)
			dim dreamsun_rnd1
			dim dreamsun_rndnum
			const ssss="abcdefghijklnmopqrstuvwxyz1234567890"
			Randomize
			Do While Len(dreamsun_rndnum)<str
			dreamsun_rnd1=int(len(ssss) * Rnd + 1)
			dreamsun_rnd1=mid(ssss,dreamsun_rnd1,1)
			dreamsun_rndnum=dreamsun_rndnum&dreamsun_rnd1
			loop
dreamsun_rnd=dreamsun_rndnum
End Function

'*************************************
'定义通用页脚
'*************************************
sub foot()
dim time2
time2=timer
footerstr = ""
Response.Write "版权所有：<b>"& bbsname &"</b> 执行时间："& FormatNumber((time2-time1)*1000,1) &" 毫秒<br />"&_
"本贴吧内容纯属发表者个人意见，与 " &" <font color=#CC0000>" & bbsname &" </font> 立场无关 "&footerstr
'因为每个页面都要调用这个，所以写在这里统一关闭。
Call connClose()
end sub
'*************************************
'定义通用的在线人数统计
'*************************************
Sub Dreamsun_onliner()
On Error Resume Next 
dim timecha,bbb,onliners,cookonline,acnow
bbb=""
acnow= now()
onlinelse="浏览:"&ggg
	cookonline=Request.Cookies("Dreamsun_POST_OL")("online")
	if cookonline="" then
	cookonline=acnow &"|" &Dreamsun_rnd(6)
	Response.Cookies("Dreamsun_POST_OL")("online")=cookonline
	end if
	timecha = formattime(dateadd("n",-20, acnow))
		dim yk_name,yk_yn
			if Dreamsun_name="" then 
				yk_name="游客"
				yk_yn=1
			else
				yk_name=Dreamsun_name
				yk_yn=0
			end if

		if conn_db_way="3" then
			sql="delete from online where Dreamsun_date < '" & timecha & "' or (Dreamsun_yk<>'"&cookonline&"' and Dreamsun_name='"&Dreamsun_name&"' and Dreamsun_name<>'游客')"
		else
			sql="delete from online where Dreamsun_date < #" & timecha & "# or (Dreamsun_yk<>'"&cookonline&"' and Dreamsun_name='"&Dreamsun_name&"' and Dreamsun_name<>'游客')"
		end if
		conn.Execute(sql)
		if conn.Execute("select Dreamsun_date from online where Dreamsun_yk='"&cookonline&"'").eof then
			Set rs_ol_num = conn.Execute("select count(*) from online")
			'如果超过了最大在线人数，则不再度对新浏览者进行统计 Add For V1.5
			If CInt(rs_ol_num(0))< CInt(maxOnline) Then
				sql = "insert into online (Dreamsun_name,Dreamsun_date,Dreamsun_action,Dreamsun_order,Dreamsun_ip,Dreamsun_yk) values('"&yk_name&"','" & acnow & "','" & onlinelse & "',"&yk_yn&",'"&reip()&"','"&cookonline&"')"
				conn.Execute (sql)
			End If 
		else
			sql = "update online set Dreamsun_name='"& yk_name &"',Dreamsun_date='" & acnow & "',Dreamsun_action='" & onlinelse & "',Dreamsun_order="&yk_yn&" where Dreamsun_yk='"&cookonline&"'"
			conn.Execute (sql)
		end if

	dim accls,acmsg,erzs,erhs,erip,Dreamsun_yk,onlineyn
onlineyn=""
	acmsg=""
	erzs=0
	erhs=0
	Dreamsun_yk=""
	'iii=0 'add by zidone for online guest 2006-12-18
	'ccc="(全部游客):"
	set onliners = conn.Execute ("select Dreamsun_name,Dreamsun_action,Dreamsun_ip,Dreamsun_order,Dreamsun_yk from online order by Dreamsun_order asc")
	do while not onliners.eof
	acmsg=onliners(1)
	erzs=erzs+1
	if onliners(3)=0 then erhs=erhs+1
	erip=onliners(2)
	if instr(onliners(4),"|")>0 then Dreamsun_yk="&#13来访时间:"&left(onliners(4),instr(onliners(4),"|")-1)
		if Dreamsun_membercls<2 and instr(erip,".")>0 then 
			erip=left(erip,instrrev(erip,".")-1)
			erip=left(erip,instrrev(erip,"."))&"***.***"
			Dreamsun_yk=""
		end if
	if onliners(0)<>"游客" Then
		credit = onliners(0)
		level = AdminLevel(CStr(onliners(0)))
		Select Case level
			Case 0
				credit = onliners(0)
			Case 1
				credit = "<font color="&boardManagerColor&">" & onliners(0) & "</font>"
			Case 9
				credit = "<font color="&superManagerColor&">" & onliners(0) & "</font>"
		End Select 

		If CStr(Dreamsun_name) = CStr(onliners(0)) Then 
			credit = "<font color="&currentUserColor&">" & onliners(0) & "</font>"
		End If 

	bbb=bbb&"&nbsp;<span onclick='' style='cursor:hand' title='用户:"&onliners(0)&"&#13位置:"&acmsg&"&#13IP:"&erip&Dreamsun_yk&"'>"&credit&"</span> "&Chr(13)&Chr(10)
			onlineyn=onlineyn &"|"& onliners(0) &"|"
	'else
		'If iii<5 Then 
			'bbb=bbb&"&nbsp;<span onclick='' style='cursor:hand' title='用户:游客&#13位置:"&acmsg&"&#13IP:"&erip&Dreamsun_yk&"'>游客</span> "&Chr(10)
			'ccc=ccc&"&nbsp;<span onclick='' style='cursor:hand' title='用户:游客&#13位置:"&acmsg&"&#13IP:"&erip&Dreamsun_yk&"'>游客</span> "&Chr(10)
		'Else
			'ccc=ccc&"&nbsp;<span onclick='' style='cursor:hand' title='用户:游客&#13位置:"&acmsg&"&#13IP:"&erip&Dreamsun_yk&"'>游客</span> "&Chr(10)
		'End if
		'iii=iii+1
	end if
	onliners.movenext
	loop
	onliners.close
	set  onliners= nothing
	if Application("onlineyn_"&webname)<>onlineyn then
Application.lock
Application("onlineyn_"&webname)=onlineyn
Application.unlock
    end If
Response.Write("<DIV id=online>")
'If iii>5 Then bbb = bbb & " … <span onclick=""if(guestlist.style.display=='none'){guestlist.style.display='block';tSign.innerHTML='<font color=blue>-</font>';}else{guestlist.style.display='none';tSign.innerHTML='<font color=red>+</font>';}"" style='cursor:hand;'>查看全部("&CStr(iii)&")位游客 <span id='tSign' name='tSign'><font color=red>+</font></span></a></span>"
Response.write"当前在线:共<font color=red>"&erzs&"</font>人 会员<font color=red>"&erhs&"</font>人。列表："
Response.write  DropFuckWords(LCase(bbb))
Response.Write("</DIV>"&vbLf)
'Response.Write("<div id='guestlist' name='guestlist' style='display:none;'>"&ccc&"</div>")
End Sub
'*************************************
'格式化时间字符串
'*************************************
Function formattime(str)
if isnull(str) then exit function
formattime=FormatDateTime(str,2)&" "&FormatDateTime(str,4)&":00"
End Function
'*************************************
'检查用户等级
'*************************************
Function AdminLevel(strUN)
	boardadmin0=""
	'是普通用户(默认)
	tmpLevel = 0
	'是分版主
	'从缓存中读出吧的相关信息
	if IsArray(Arr_Category) And ubound(Arr_Category,1)<>0 then
		Category_Len=ubound(Arr_Category,2)
			For kj=0 To Category_Len
				If boardadmin0 <>"" Then 
					boardadmin0 = boardadmin0 &"!"& Arr_Category(3,kj)
				Else
					boardadmin0 = Arr_Category(0,kj)
				End If 
			Next
	End If 
	If boardadmin0 <>"" Then 
		For jj = 0  To UBound(Split(boardadmin0,"!"))
			If Split(boardadmin0,"!")(jj)<>"" Then 
				tdim0=Split(Split(boardadmin0,"!")(jj),"|")
				For ti0=0 To ubound(tdim0)
					If strUN = tdim0(ti0) Then tmpLevel=1 '分版版主
				Next
			End If 
		Next 
	End If 
	'是最高管理员
	tdim=split(bbsbanzhu,"|")
	For ti=0 To ubound(tdim)
		If strUN=tdim(ti) Then tmpLevel = 9 '超级管理员
	Next
	AdminLevel = tmpLevel
End Function 
'*************************************
'定义文字友情链接
'*************************************
Function friendlink(linktr,tdw,linkclass)
If linktr="" Then linktr=2 '每行几个
If tdw="" Then tdw=100 '每个单元格的宽度
lianjieliebiao="<TABLE cellSpacing=1 cellPadding=0 border=0>"& vbCrLf
lianjieliebiao=lianjieliebiao&"        <TBODY>"& vbCrLf
lianjieliebiao=lianjieliebiao&"        <TR align=middle>"& vbCrLf
tr=1
hang=1
sql_fl = "SELECT link_name,link_url,link_info FROM "&linktable&" where link_type=0 ORDER BY link_order DESC,id DESC" 
Set rs_fl = Server.CreateObject("ADODB.Recordset")
	rs_fl.OPEN sql_fl,Conn,0,1
		if rs_fl.eof and rs_fl.bof then
			lianjieliebiao=lianjieliebiao&"<td>还没有链接</td>"
		else
			do until rs_fl.eof'开始循环
				bn=rs_fl(0)
				If boardid=rs_fl(1) Then bn="<b>"&rs_fl(0)&"</b>"
				listid=listid&"<td><A href="""&rs_fl(1)&""" title="""&rs_fl(2)&""" target=blank>"&bn&"</A></TD>"& vbCrLf
				tr=tr+1'方格子个数加1
				if tr > linktr Then'如果方格子大于了规定的换行数
					listid=listid&"</tr><TR align=middle class=""zd_td"">"'输出换行
					hang=hang+1'行数加1，为的是不至于在一行上如果达不到规定的方格子数而补齐出现空白
					tr=1'方格子重新计数，从1开始
				End If
			rs_fl.movenext
			Loop
			listid=listid&"<td>常网信息网</TD>"& vbCrLf
			if tr<linktr And hang>1 then'如果方格子数目小于规定换行数且多于一行，就要用空行补齐，免得出现错位。
				for m=tr to linktr-1'开始循环，之所以到规定数目-1，是因为上面手工添加了一个单元格 全部分类。否则会出现多一个的问题
					listid=listid&"<td> </td>"
				next
			end if'补齐判断结束
		end if'输出判断结束
	rs_fl.close
Set rs_fl=Nothing
'输出分类列表单元格。
friendlink=lianjieliebiao&listid&"</TR></TBODY></TABLE>"
End Function

'*************************************
'定义图片广告链接
'*************************************
Function freeadv()
sql_fl = "SELECT link_name,link_url,link_info FROM "&linktable&" where link_type=1 ORDER BY link_order DESC,id DESC" 
Set rs_fl = Server.CreateObject("ADODB.Recordset")
	rs_fl.OPEN sql_fl,Conn,0,1
		if rs_fl.eof and rs_fl.bof then
			freeadv=""
		else
			do until rs_fl.eof'开始循环
				bn=rs_fl(0)
				freeadv=freeadv&"<div class=freeadvin><A href="""&rs_fl(1)&""" title="&bn&" target=blank><img src="""&rs_fl(2)&""" border=0></A></div>"& vbCrLf
			rs_fl.movenext
			Loop
		end if'输出判断结束
	rs_fl.close
Set rs_fl=Nothing
'输出分类列表单元格。
End Function

'*************************************
'获得插件
'*************************************
Function GetPlugIn(str)
	Dim gplgn_id,gplgn_url,gplgn_para,gplgn_folder
	str = Replace(str," ","")
	If InStr(str,"()")>0 Then 
		gplgn_para =""
		gplgn_id = Replace(str,"()","")
	Else
		gplgn_para =Replace(Split(str,"(")(1),")","")
		gplgn_id = Split(str,"(")(0)
	End If 

	Set fso=Server.CreateObject("Scripting.FileSystemObject")
	Set objFolder=fso.GetFolder(Server.MapPath("./plug-in"))
	Set objSubFolders=objFolder.Subfolders
	for each objSubFolder in objSubFolders 
		If objSubFolder.Name = gplgn_id Then 
			If fso.FileExists(objSubFolder+"\config.xml") Then 
				set xmldoc=Server.createObject("Microsoft.XMLDOM")
				xmldoc.load(objSubFolder+"\config.xml")
				set nodes=xmldoc.selectNodes("//setting")
				gplgn_folder = Replace( Request.ServerVariables("PATH_INFO"),Split(Request.ServerVariables("PATH_INFO"),"/")(UBound(Split(Request.ServerVariables("PATH_INFO"),"/"))),"")
				gplgn_url ="http://" &  Request.ServerVariables("HTTP_HOST") & gplgn_folder & "plug-in/"+objSubFolder.Name+"/"+nodes(0).childNodes(7).text+"?para="+gplgn_para
				GetPlugIn =GetDataFromURL(gplgn_url)
			Else
				GetPlugIn = "Null"
			End If 
		End If 
	next 
	Set objFolder=nothing
	Set objSubFolders=nothing
	Set fso=nothing
End Function 
'*************************************
'从网页中获得数据
'*************************************
Function GetDataFromURL(url)
    On error resume next 
	Set Retrieval = Server.CreateObject("Microsoft.XMLHTTP")
	if err.number<>0 then
	On error goto 0
	Set Retrieval = Server.CreateObject("Msxml2.XMLHTTP")
	end if
          With Retrieval
          .Open "GET", url, False, "", ""
          .Send
          GetDataFromURL = .ResponseText
          End With
    Set Retrieval = Nothing
End Function

Function bytes2BSTR(arrBytes) 
strReturn = "" 
arrBytes = CStr(arrBytes) 
For ix = 1 To LenB(arrBytes) 
ThisCharCode = AscB(MidB(arrBytes, ix, 1)) 
If ThisCharCode < &H80 Then 
strReturn = strReturn & Chr(ThisCharCode) 
Else 
NextCharCode = AscB(MidB(arrBytes, ix+1, 1)) 
strReturn = strReturn & Chr(CLng(ThisCharCode)*&H100 + CInt(NextCharCode)) 
ix = ix + 1 
End If 
Next 
bytes2BSTR = strReturn 
End Function 
'*************************************
'复制/数据库得备份中用到，需要FSO
'*************************************
Function CopyFiles(TempSource,TempEnd)
    Dim FSO
    Set FSO = Server.CreateObject("Scripting.FileSystemObject")
	IF FSO.FileExists(TempEnd) then
       Response.Write "目标备份文件 <b>" & TempEnd & "</b> 已存在，请先删除!"
       Set FSO=Nothing
       Exit Function
    End IF
    IF FSO.FileExists(TempSource) Then
    Else
       Response.Write "要复制的源数据库文件 <b>"&TempSource&"</b> 不存在!"
       Set FSO=Nothing
       Exit Function
    End If
    FSO.CopyFile TempSource,TempEnd
    Response.Write "已经成功复制文件 <b>"&TempSource&"</b> 到 <b>"&TempEnd&"</b>"
    Set FSO = Nothing
End Function
'*************************************
'删除/数据库得备份中用到，需要FSO
'*************************************
Function DeleteFiles(FilePath)
    Dim FSO
    Set FSO=Server.CreateObject("Scripting.FileSystemObject")
    IF FSO.FileExists(FilePath) Then
		FSO.DeleteFile FilePath,True
		DeleteFiles = 1
    Else
		DeleteFiles = 0
    End IF
    Set FSO = Nothing
End Function
'*************************************
'日期转换函数
'*************************************
Function DateToStr(DateTime,ShowType) 
	Dim DateMonth,DateDay,DateHour,DateMinute
	DateMonth=Month(DateTime)
	DateDay=Day(DateTime)
	DateHour=Hour(DateTime)
	DateMinute=Minute(DateTime)
	If Len(DateMonth)<2 Then DateMonth="0"&DateMonth
	If Len(DateDay)<2 Then DateDay="0"&DateDay
	Select Case ShowType
	Case "Y-m-d"  
		DateToStr=Year(DateTime)&"-"&DateMonth&"-"&DateDay
	Case "m-d"  
		DateToStr=DateMonth&"-"&DateDay
	Case "Y-m-d H:I A"
		Dim DateAMPM
		If DateHour>12 Then 
			DateHour=DateHour-12
			DateAMPM="PM"
		Else
			DateHour=DateHour
			DateAMPM="AM"
		End If
		If Len(DateHour)<2 Then DateHour="0"&DateHour	
		If Len(DateMinute)<2 Then DateMinute="0"&DateMinute
		DateToStr=Year(DateTime)&"-"&DateMonth&"-"&DateDay&" "&DateHour&":"&DateMinute&" "&DateAMPM
	Case "Y-m-d H:I:S"
		Dim DateSecond
		DateSecond=Second(DateTime)
		If Len(DateHour)<2 Then DateHour="0"&DateHour	
		If Len(DateMinute)<2 Then DateMinute="0"&DateMinute
		If Len(DateSecond)<2 Then DateSecond="0"&DateSecond
		DateToStr=Year(DateTime)&"-"&DateMonth&"-"&DateDay&" "&DateHour&":"&DateMinute&":"&DateSecond
	Case "YmdHIS"
		DateSecond=Second(DateTime)
		If Len(DateHour)<2 Then DateHour="0"&DateHour	
		If Len(DateMinute)<2 Then DateMinute="0"&DateMinute
		If Len(DateSecond)<2 Then DateSecond="0"&DateSecond
		DateToStr=Year(DateTime)&DateMonth&DateDay&DateHour&DateMinute&DateSecond	
	Case "ym"
		DateToStr=Right(Year(DateTime),2)&DateMonth
	Case "ymd"
		DateToStr=Right(Year(DateTime),2)&DateMonth&DateDay
	Case "d"
		DateToStr=DateDay
	Case Else
		If Len(DateHour)<2 Then DateHour="0"&DateHour
		If Len(DateMinute)<2 Then DateMinute="0"&DateMinute
		DateToStr=Year(DateTime)&"-"&DateMonth&"-"&DateDay&" "&DateHour&":"&DateMinute
	End Select
End Function

'*************************************
'操作数据库
'parameters sql : 要执行的SQL语句
'parameters rec : 影响记录的条数
'说明: 不适用于操作大量数据，适用于操作单个数据
'Atrribute Add For V1.5 2007-11-11 CHANG,ZIDONE
'*************************************
Function OptTable(sql)
	Dim optAct
	Dim result,resultString
	optAct = Split(sql," ")(0)
	Select Case optAct
		Case "select"
			Set resultString= Server.CreateObject("ADODB.Recordset")
			resultString.Open sql, Conn,1,3
			if not resultString.Eof then
			result = resultString(0)
			else
			result = ""
			end if
			Set resultString = nothing
		Case "insert" 
			Conn.Execute Sql,result
		Case "update"
			Conn.Execute Sql,result
		Case "delete"
			Conn.Execute Sql,result
	End Select 
	OptTable = result
End Function

sub rsClose()
	Rs.Close
	set rs=nothing
End sub
sub connClose()
	conn.close
	set conn=Nothing
End sub
'*************************************
'取得数据表的最大下一个ID
'代替自动编号
'Atrribute Add For V1.5 2007-11-11 CHANG,ZIDONE
'*************************************
Function GetMaxID(table,cols)
	miSql = "select "+cols+" from "+table+" order by "+cols+" desc"
	'miSql = "select max("+cols+") from "& table
	miStr = OptTable(miSql)
	if miStr="" then
		GetMaxID=1
	else
		GetMaxID=CInt(miStr)+1
	end if
End function
'*************************************
'换过滤脏话[包括色情/反动/宗教/恐怖等]
'*************************************
Function DropFuckWords(Content)
	bytes=split(zanghuaguolv,"|")
	for ii=0 to ubound(bytes)
	Content=replace(Content,trim(bytes(ii)),zanghuaguolvChar)
	Next
	DropFuckWords = Content
End Function 

'*************************************
'判断是否是广告帖
'返回 True/False
'Atrribute Add For V1.5 2007-11-11 CHANG,ZIDONE
'*************************************
Function IsAdTopic(str)
	IsAdTopic = False
	if right(adFilter,1)="|" then adFilter = left(adFilter,len(adFilter)-1)
	adFilterArr = Split(adFilter,"|")
	For adI = 0 to Ubound(adFilterArr)
		If InStr(str,adFilterArr(adI))>0 Then
			IsAdTopic = True
			Exit For
		End If
	Next
End function
'*************************************
'判断是否含有禁止注册的用户名
'返回 True/False
'Atrribute Add For V1.5 2007-11-11 CHANG,ZIDONE
'*************************************
Function IsKeptUser(str)
	IsKeptUser = False
	if right(keepUsername,1)="|" then keepUsername = left(keepUsername,len(keepUsername)-1)
	keepUsernameArr = Split(keepUsername,"|")
	For kuI = 0 to Ubound(keepUsernameArr)
		'If InStr(str,keepUsernameArr(kuI))>0 Then
		If keepUsernameArr(kuI) = str Then
			IsKeptUser = True
			Exit For
		End If
	Next
End function

'*************************************
'异步取得IP地址的详细地址
'返回 String
'部分权力归纯真网络所有，本程序不承担与其有关的连带责任
'部分权力归91Webs所有，本程序不承担与之有关的连带责任
'版权疑问请阅读本程序 关于版权的说明
'Atrribute Add For V1.5 2007-11-16 CHANG,ZIDONE
'*************************************
Function GetIpLocation(ip, url)
	Dim allstring
	Dim StartPos,EndPos
	allstring = GetDataFromURL(url&ip)
	if instr(url,"cz88")>0 then
		StartPos = instr(allString,"InputIPAddrMessage")
		if startpos <=0 then allString = "N/A1"
		StartPos = instr(startpos,allString,">")
		if startpos <=0 then allString = "N/A2"
		EndPos = instr(startpos,allString,"<")
		if endpos <=0 then allString = "N/A3"
		if StartPos>=EndPos then
			allString = allString +"N/A4"
		else
			allString = Mid(allString,StartPos+1,(EndPos-StartPos-1))
			
		end if
		GetIpLocation =allString
	elseif instr(url,"91webs")>0 or instr(url,"xaut")>0 then
		If InStr(allString,":")>0 Then
			allString = Mid(allString,InStr(allString,":")+1,(Len(allString)-InStr(allString,":")))
		End if
		GetIpLocation = allString
	end if
End Function

'*************************************
'对应URLEncode函数
'返回 String
'Atrribute Add For V1.5 2007-11-16 CHANG,ZIDONE
'*************************************
Function UrlDecode(encodestr) 
 Dim newstr,havechar,lastchar,i,char_c,next_1_c,next_1_Num
 newstr="" 
 havechar=false 
 lastchar="" 
 for i=1 to len(encodestr) 
  char_c=mid(encodestr,i,1) 
  if char_c="+" then 
   newstr=newstr & " " 
  elseif char_c="%" then 
   next_1_c=mid(encodestr,i+1,2) 
   next_1_num=cint("&H" & next_1_c) 
   
   if havechar then 
    havechar=false 
    newstr=newstr & chr(cint("&H" & lastchar & next_1_c)) 
   else 
    if abs(next_1_num)<=127 then 
     newstr=newstr & chr(next_1_num) 
    else 
     havechar=true 
     lastchar=next_1_c 
    end if 
   end if 
   i=i+2 
  else 
   newstr=newstr & char_c 
  end if 
 next 
 urldecode=newstr 
end function

'*************************************
'列表页中显示回复数大于1页的分页号
'返回 String
'参数1: 超链接的URL(string)
'参数2: 总共有多少条回复(integer)
'参数3: 每页显示多少条(integer)
'参数4: 是否在新窗口显示超链接(true/false)
'Atrribute Add For V1.5 2007-11-22 CHANG,ZIDONE
'*************************************
Function GetRePageNo(url,recCount,pgSize,newpage)
	Dim grpn_pages
	Dim grpn_target
	Dim grpn_result
	if (recCount Mod pgSize) <> 0 then
		grpn_pages = CInt(Split(CStr(recCount/pgSize),".")(0))+1
	else 
		grpn_pages = Cint(recCount/pgSize)
	end if
	if newpage = true then
		grpn_target = " target='_blank'"
	end if
	grpn_result = "<font color=gray>[</font>"
	for grpn_i= 1 to grpn_pages
		if grpn_i>4  then
			if grpn_pages=5 then
				grpn_result = grpn_result & ",<a title='第"&grpn_i&"页' "&target&" href='"&url&grpn_i&"'>"&grpn_i&"</a>"
			elseif grpn_pages > 5 then
				grpn_result = grpn_result& "…<a title='末页' "&target&" href='"&url&grpn_pages&"'>"&grpn_pages&"</a>"
			end if 
		exit for
		end if
		if grpn_i > 1 then grpn_result = grpn_result&","
		grpn_result = grpn_result & "<a title='第"&grpn_i&"页' "&target&" href='"&url&grpn_i&"'>"&grpn_i&"</a>"
	next
	grpn_result =grpn_result & "<font color=gray>]</font>"
	GetRePageNo = grpn_result
End Function
%>