<%
Call tostopip(2)'判断是否开放浏览
Dim time1
time1=Timer()
'*************************************
'检查用户等级
'*************************************
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(Sys_Admin,"|")
	For ti=0 To ubound(tdim)
		If strUN=tdim(ti) Then tmpLevel = 9 '超级管理员
	Next
	AdminLevel = tmpLevel
End Function 
'*************************************
'判断是否管理员，返回管理员级别。CheckAdmin(分类id，可以为空)
'2010-01-11
'*************************************
Function CheckAdmin(BoardID)
	'强制赋值
	CheckAdmin=0
	If Dreamsun_Name="" Then
		CheckAdmin=0
	'如果用户未登录，就是空，否则：
	Else
		If InStr("|"&Lcase(sys_Admin)&"|","|"&Lcase(DreamSun_name)&"|")>0  Then'如果用户在管理员列表里面，那么肯定是最高权限了。
			CheckAdmin=9
		Else
			If BoardID<>0 And BoardID<>"" Then
				'如果板块不为空，获取版主
				Get_Board_Admin=CheckAdminName(BoardID)
				'到此，构建了一个版主组合Get_Board_Admin
				If InStr("|"&Lcase(Get_Board_Admin)&"|","|"&Lcase(DreamSun_name)&"|")>0  Then CheckAdmin=1
			End If 
		End If 
	End If
End Function
'*************************************
'判断管理员名字返回管理员级别。CheckAdminName(分类id，可以为空,空的时候返回总版主)
'2010-01-11
'*************************************
Function CheckAdminName(BoardID)
	CheckAdminName="" '强制赋值
	If BoardID<>0 And BoardID<>"" Then
	'如果板块不为空，获取版主
		If Not IsArray(Arr_Category) Then GetBoardCache()
		If IsArray(Arr_Category) Then
			For i=0 To Ubound(Arr_Category,2)
			IF Arr_Category(1,i)=BoardID Then
				Get_Board_Admin=Arr_Category(3,i)
				Get_Board_Father=Arr_Category(5,i)
				Exit For
			End IF
			Next
		End If
		'版主获取到了,判断如果是二级分类，那么要获取父亲的版主。
		If Get_Board_Father<>0 Then 
			For i=0 To Ubound(Arr_Category,2)
			IF Arr_Category(1,i)=Get_Board_Father Then
				Get_Board_Admin_f=Arr_Category(3,i)
				Exit For
			End IF
			Next
			Get_Board_Admin=Get_Board_Admin &"|"& Get_Board_Admin_f
		End If
		'到此，构建了一个版主组合Get_Board_Admin
	Else
		Get_Board_Admin=sys_Admin
	End If
	If Left(Get_Board_Admin,1)="|" Then Get_Board_Admin=Right(Get_Board_Admin,Len(Get_Board_Admin)-1)
	If Right(Get_Board_Admin,1)="|" Then Get_Board_Admin=Left(Get_Board_Admin,Len(Get_Board_Admin)-1)
	Get_Board_Admin=Replace(Get_Board_Admin&"","||","")
	CheckAdminName=Get_Board_Admin
End Function
'*************************************
'数字检查安全验证函数
'*************************************
function CheckNum(str)
	If isnull(str) or str="" then Str=0
	If not isnumeric(str) then Call backmsg("!","")
	CheckNum=int(str)
End Function
'*************************************
'文本检查安全验证函数
'*************************************
Function Checkstr(Str)
	If Isnull(Str) Then
		CheckStr = ""
		Exit Function 
	End If
	Str = Replace(Str,Chr(0),"")
	CheckStr = Replace(Str,"'","''")
End Function
'*************************************
'定义是否登陆
'*************************************
Sub checkuser()
	If DreamSun_name="" Then
		Response.Write("<script>alert(""对不起，请先登陆才能进行操作！"");this.location.href='user.asp';</script>")
	response.end
	End If 
End Sub 
'*************************************
'去掉所有的ubb标签，只保留纯文字
'*************************************
Function RemoveUBB(strHTML)
	If strHTML="" Then Exit Function
	strHTML=strHTML&"[b]"
	Dim objRegExp, Match, Matches
	Set objRegExp = New Regexp
	objRegExp.IgnoreCase = True
	objRegExp.Global = True
	'取闭合的<>
	objRegExp.Pattern = "\[(.*?)\]"
	'进行匹配
	Set Matches = objRegExp.Execute(strHTML)
	' 遍历匹配集合，并替换掉匹配的项目
	For Each Match in Matches
	strHtml=Replace(strHTML,Match.Value,"")
	Next
	Set objRegExp = Nothing
	RemoveUBB=Replace(Replace(Replace(Replace(strHTML,Chr(10),"")," ",""),Chr(13),""),"　","")
End Function
'*************************************
'执行时间
'*************************************
Function runTime()
	endtime=timer()
	runTime="页面执行<a href=""so.asp?Action=c"" title=""清空缓存""><font color=""#FFFFFF"">"&FormatNumber((endtime-time1)*1000,3)&"</font></a>毫秒"
End Function 

'通用表格显示（标题，内容，返回路径）
Function ShowTable(Str1,Str2,Str3)
	ShowTable= ShowTable & "<center><table border=0 cellSpacing=1 cellPadding=5 class=""zd_table"" align=center width=600><tr class=""zd_td"" height=28><td align=left>★"&Str1&"★</td></tr>"
	ShowTable= ShowTable & "<tr height=60 class=""zd_td""><td align=left>"
	ShowTable= ShowTable & Str2&"</td></tr>"
	If Str3<>"" Then
		ShowTable= ShowTable & "<tr height=20 class=""zd_td""><td align=center><a href="""&Str3&""">返回"&Str3&"</a></td></tr>"
		ShowTable= ShowTable & "<meta http-equiv=""refresh"" content=""2;url='"&Str3&"'"">"
	End If 
	ShowTable= ShowTable & "</table></center>"
End Function
'*************************************
'站长加油站 专用页码简化版,取得显示页码
'*************************************
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
		If Dreamsun_cls<>"" And Left(Dreamsun_cls,1)<>"&" Then Dreamsun_cls="&"&Dreamsun_cls
			   viewpage=viewpage& "<div class=""meneame""><em>&nbsp;" & p_c &"/&nbsp;"&p_y&"</em> "
               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& "<strong>"& p_m &"</strong>"
			   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& "<input type=""text"" name=""custompage"" size=""3"" onkeydown=""if(event.keyCode==13) {window.location='"&showfile&"?abc=1"&Dreamsun_cls&"&amp;CurPage='+this.value; return false;}""/></div>"& 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
'*************************************
'获取文字长度，中文也算1个
'*************************************
Function GetStrLen(t0)
    'On Error Resume Next
    WINNT_CHINESE=(Len("中国")=2)
    IF WINNT_CHINESE Then
        L=Len(t0)
        T=l
        For I=1 To L
            C=Asc(Mid(t0,I,1))
            IF C<0 Then C=C+65536
            IF C>255 Then
                T=T+1
            End IF
        Next
        GetStrLen=T
    Else
        GetStrLen=Len()
    End IF
    'IF Err.Number<>0 Then Err.Clear
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 
'*************************************
'个性签名函数
'*************************************
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 
'*************************************
'定义快捷登陆区域
'*************************************
Function bbslogin()
if Dreamsun_name= "" then
	bbslogin="<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 class='hot' title='普通会员'>" & mes & "</font>"
		Case 1
			mes = "<font class='hot' title='版主'>" & mes & "</font>"
		Case 9
			mes = "<font class='hot' title='系统管理员'>" & mes & "</font>"
	End Select 
	bbslogin=bbslogin & "欢迎 " & mes &" | <A href='user.asp?Action=modifypassword'>我的</A> | <A href='usersms.asp'>消息</A><span id=msg_num></span> | "
	If CInt(level)>0 Then bbslogin=bbslogin &  " <A href='so.asp'>管理</A> | "
	If CInt(isadmin)=9 Then bbslogin=bbslogin &  " <A href='admin.asp'>后台</A> | "
	bbslogin=bbslogin &  " <A href='user.asp?Action=exit'>退出</A>"
end if
End Function 
'*************************************
'定义横向导航菜单
'*************************************
Function BoardList(Ast)
	If Not IsArray(Arr_Category) Then GetBoardCache()
	if UBound(Arr_Category,1)=0 then TempStr=TempStr&"<li>还没有分类</li>":exit Function
	For k=0 To ubound(Arr_Category,2)
		If Arr_Category(5,k)=0 Then  
			TempStr=TempStr&"<li"
			If Arr_Category(1,k)=Ast Or Arr_Category(1,k)=GetBoardFather(Ast) Then TempStr=TempStr&" class=""current"""
			TempStr=TempStr&"><a href="""&list_page_name&"?boardid="&Arr_Category(1,k)&""">"&Arr_Category(0,k)&"</a></li>"
		End If 
	Next
	TempStr=TempStr&"<li><a href="""&list_page_name&""">全部分类</a></li>"
	BoardList=TempStr
End Function 
'*************************************
'定义二级分类选单
'*************************************
Function BoardListSon(Ast)
	If Ast="" Or Ast=0 Then Exit Function
	If Not IsArray(Arr_Category) Then GetBoardCache()
	if UBound(Arr_Category,1)=0 then TempStr=TempStr&"<li>还没有分类</li>":exit Function
	'显示孩子分类
	For k=0 To ubound(Arr_Category,2)
		If Arr_Category(5,k)=Ast Then 
		TempStr=TempStr&"<li><a href="""&list_page_name&"?boardid="&Arr_Category(1,k)&""">"&Arr_Category(0,k)&"</a></li>"
		End If
	Next
	'显示兄弟分类
	If GetBoardFather(Ast)<>0 Then 
		For kkk=0 To ubound(Arr_Category,2)
			If Arr_Category(5,kkk)=GetBoardFather(Ast) Then 
				TempStr=TempStr&"<li"
				If Arr_Category(1,kkk)=Ast Then TempStr=TempStr&" class=""cur"""
				TempStr=TempStr&"><a href="""&list_page_name&"?boardid="&Arr_Category(1,kkk)&""">"&Arr_Category(0,kkk)&"</a></li>"
			End If
		Next
	End If 
	BoardListSon=TempStr
End Function 
'*************************************
'定义分类下拉菜单
'*************************************
Function BoardSelect(BoardID)
	TempStr="<select name=""BoardId""><option value=''>请选择分类</option>"
		For kkk=0 To ubound(Arr_Category,2)
			If int(Arr_Category(5,kkk))=0 Then 
				TempStr= TempStr &"<option value='"&Arr_Category(1,kkk)&"'"
				if Int(Arr_Category(1,kkk))=Int(BoardID) then TempStr= TempStr &" selected"
				TempStr= TempStr &">"&Arr_Category(0,kkk)&"</option>"
					For i=0 To Ubound(Arr_Category,2)
					IF Arr_Category(5,i)=Arr_Category(1,kkk) Then
						TempStr= TempStr &"<option value='"&Arr_Category(1,i)&"'"
						if Int(Arr_Category(1,i))=Int(BoardID) then TempStr= TempStr &" selected"
							TempStr= TempStr &">&nbsp;&nbsp;"&Arr_Category(0,i)&"</option>"
						End IF
					Next
			End If 
		Next
	TempStr= TempStr &"</select>"
BoardSelect=TempStr
End Function 
'*************************************
'过滤超链接
'*************************************
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
'*************************************
'过滤超链接
'*************************************
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
'*************************************
'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")
'-----------普通标签----------------
	re.Pattern="\[color\s*=\s*([^\]]+?)\]"
	Content=re.Replace(Content,"<font color=""$1"">")
	re.Pattern="\[size\s*=\s*(\d+?)\]"
	Content=re.Replace(Content,"<font size=""$1"">")
	re.Pattern="\[font\s*=\s*([^\]]+?)\]"
	Content=re.Replace(Content,"<font face=""$1"">")
	re.Pattern="\[\/(color|size|font)\]"
	Content=re.Replace(Content,"</font>")	
	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="\[s\]([^\r]*?)\[\/s\]"
	Content=re.Replace(Content,"<s>$1</s>")
    re.Pattern="\[sup\]([^\r]*?)\[\/sup\]"
	Content=re.Replace(Content,"<sup>$1</sup>")
    re.Pattern="\[sub\]([^\r]*?)\[\/sub\]"
	Content=re.Replace(Content,"<sub>$1</sub>")
'-----------多媒体标签----------------
	re.Pattern="\[flash\]([\s\S]+?)\[\/flash\]"
	Content=re.Replace(Content,"<embed type=""application/x-shockwave-flash"" src=""$3"" wmode=""opaque"" quality=""high"" bgcolor=""#ffffff"" menu=""false"" play=""true"" loop=""true"" width=""550"" height=""400""/>")
	re.Pattern="\[flash\s*(?:=\s*(\d+)\s*,\s*(\d+)\s*)\]([\s\S]+?)\[\/flash\]"
	Content=re.Replace(Content,"<embed type=""application/x-shockwave-flash"" src=""$3"" wmode=""opaque"" quality=""high"" bgcolor=""#ffffff"" menu=""false"" play=""true"" loop=""true"" width=""$1"" height=""$2""/>")
	re.Pattern="\[flash\]([\s\S]+?)\[\/flash\]"
	Content=re.Replace(Content,"<embed type=""application/x-shockwave-flash"" src=""$3"" wmode=""opaque"" quality=""high"" bgcolor=""#ffffff"" menu=""false"" play=""true"" loop=""true"" width=""550"" height=""400""/>")
	re.Pattern="\[media\]([\s\S]+?)\[\/media\]"
	Content=re.Replace(Content,"<embed id=Windows_Media_Player name=Windows_Media_Player src=""$1"" enablecontextmenu=""false"" autostart=""1"" width=""550"" height=""400""/>")
	re.Pattern="\[media\s*=\s*(\d+)\s*,\s*(\d+)\s*\]([\s\S]+?)\[\/media\]"
	Content=re.Replace(Content,"<embed id=Windows_Media_Player name=Windows_Media_Player src=""$3"" enablecontextmenu=""false"" autostart=""1"" width=""$1"" height=""$2""/>")
	re.Pattern="\[media\s*=\s*(\d+)\s*,\s*(\d+)\s*,\s*(\d+)\s*\]([\s\S]+?)\[\/media\]"
	Content=re.Replace(Content,"<embed id=Windows_Media_Player name=Windows_Media_Player src=""$4"" enablecontextmenu=""false"" autostart=""$3"" width=""$1"" height=""$2""/>")
'-----------早期的多媒体标签----------------
	if inStr(lcase(Content),"[/wma]")>0 then
	re.Pattern="\[WMA\](.[^\[]*)\[\/WMA\]"
	Content=re.Replace(Content,"<Embed src=""$1""  type='audio/x-pn-realaudio-plugin' controls='StatusBar,ControlPanel' height=56 width=273 autostart=0></embed>")
	end if
	if inStr(lcase(Content),"[/wmv]")>0 then
	re.Pattern="\[WMV\](.[^\[]*)\[\/WMV\]"
	Content=re.Replace(Content,"<EMBED id=Windows_Media_Player name=Windows_Media_Player src=""$1"" width=480 height=330 AutoStart=1></EMBED>")
	end if
	if inStr(lcase(Content),"[/mp3]")>0 then
	re.Pattern="\[MP3\](.[^\[]*)\[\/MP3\]"
	Content=re.Replace(Content,"<Embed src=""$1""  type='audio/x-pn-realaudio-plugin' controls='StatusBar,ControlPanel' height=56 width=273 autostart=0></embed>")
	end if
'-----------普通标签----------------
	re.Pattern="\[img\]\s*([\s\S]+?)\s*\[\/img\]"
	Content=re.Replace(Content,"<img src=""$1"" border=""0"" />")
	re.Pattern="\[img\s*=\s*(\d+)\s*,\s*(\d+)\s*\]\s*([\s\S]+?)\s*\[\/img\]"
	Content=re.Replace(Content,"<img src=""$3"" width=""$1"" height=""$2"" border=""0"" />")
	re.Pattern="\[img\s*=\s*(\d+)\s*,\s*(\d+)\s*,\s*(\w+)\s*\]\s*([\s\S]+?)\s*\[\/img\]"
	Content=re.Replace(Content,"<img src=""$4"" width=""$1"" height=""$2"" align=""$3"" border=""0"" />")
	re.Pattern="\[img\s*=\s*(\w+)\s*\]\s*([\s\S]+?)\s*\[\/img\]"
	Content=re.Replace(Content,"<img src=""$2"" align=""$1"" border=""0"" />")

	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="\[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="\[email\]\s*([^\]\s]+?)\s*\[\/email\]"
	Content=re.Replace(Content,"<a href=""mailto:$1"">$1</a>")
	re.Pattern="\[email\s*=\s*([^\]\s]+?)\s*\]\s*([\s\S]+?)\s*\[\/email\]"
	Content=re.Replace(Content,"<a href=""mailto:$1"">$2</a>")
	re.Pattern="\[table\]"
	Content=re.Replace(Content,"<table>")
	re.Pattern="\[table\s*=\s*(\d{1,4}%?)\s*\](<br>)?"
	Content=re.Replace(Content,"<table width=""$1"">")
	re.Pattern="\[table\s*=\s*(\d{1,4}%?)\s*,\s*([^\]]+)\s*](<br>)?"
	Content=re.Replace(Content,"<table width=""$1"" bgcolor=""$2"">")
	re.Pattern="\[tr\](<br>)?"
	Content=re.Replace(Content,"<tr>")
	re.Pattern="\[tr\s*=(\s*[^\]]+)\](<br>)?"
	Content=re.Replace(Content,"<tr bgcolor=""$1"">")
	re.Pattern="\[td\](<br>)?"
	Content=re.Replace(Content,"<td>")
	re.Pattern="\[td\s*=\s*(\d{1,2})\s*,\s*(\d{1,2})\s*\](<br>)?"
	Content=re.Replace(Content,"<td colspan=""$1"" rowspan=""$2"">")
	re.Pattern="\[td\s*=\s*(\d{1,2})\s*,\s*(\d{1,2})\s*,\s*(\d{1,4}%?)\](<br>)?"
	Content=re.Replace(Content,"<td colspan=""$1"" rowspan=""$2"" width=""$3"">")
	re.Pattern="\[\/(table|tr|td)\](<br>)?"
	Content=re.Replace(Content,"</$1>")	
	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 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

' 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 backmsg("您所在的IP地址已经被暂时不允许注册新用户","/")
					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
'*************************************
'Copyright
'*************************************
Function poweredInfo()
	poweredInfo="<div>P"&"o"&"w"&"e"&"r"&" B"&"y"&"：<a href=""ht"&"tp:"&"/"&"/"&"w"&"w"&"w."&"8"&"8"&"r"&"e"&"n"&"w"&"u"&".c"&"o"&"m""  target=""_blank""><font color=""#FFFFFF"">w"&"w"&"w."&"8"&"8"&"r"&"e"&"n"&"w"&"u"&".c"&"o"&"m</font></a> <em>"&TieBa_version&"</em></div><div>&copy; 2"&"0"&"1"&"0-"&Year(Now())&"</div>"
	'这里是调用短消息提示功能的。
	If Dreamsun_Name<>"" Then
		If zxwz Then zxwzStr="get_wz('"&currWZ&"');"
		poweredInfo=poweredInfo&"<script>"&zxwzStr&"window.setInterval(""get_msg()"",30000);</script>"
	End If 
End Function 
'虚拟删除主题.
'返回提示.
Function delTopic(id)
	Set rs= Server.CreateObject("ADODB.Recordset")
		rs.Open "Select title,IsCheck,boardid From "&bbsTable&" where id="&id, conn,3,3
		title=rs("title")
		If CheckAdmin(rs("boardid"))>0 Then 
			IsCheck=rs("IsCheck")
			If IsCheck<>-1 Then 
				rs("IsCheck")=-1	'虚拟删除主题,回复暂时不管了，回收站处理
				Set rs_u= Server.CreateObject("ADODB.Recordset")
					sql_u="Select "&bbstable&".username as zuozhe,"&usertable&".username From "&bbstable&","&usertable&" where "&usertable&".username="&bbstable&".username and "&bbstable&".id="&id
					rs_u.Open sql_u,conn,3,3
					if not rs_u.eof Then 
						username=rs_u("zuozhe")
						'判断删除帖子的是不是作者本人，若是，就扣相应添加的分，否则就是那个删除的分数
							If username=Dreamsun_name Then
								Sys_Del_Money_t=Sys_Add_Money
							Else
								Sys_Del_Money_t=Sys_Del_Money
							End If 
						conn.execute("update ["&usertable&"] set [umoney]=umoney-"&Sys_Del_Money_t&" where [username]='"&username&"'")
						qian=",扣除 "&username&" 积分"&Sys_Del_Money_t&"分"
					' 删除成功后,给[ACCOUNT]表中插入积分记录
						conn.execute("insert into [account] (accID,accValue,accFromUser,accToUser,accTime,accReason,accRemark) values("&CStr(GetMaxID("account","accid"))&","&CStr(Sys_Del_Money_t)&",'"&username&"','"&"系统"&"','"&CStr(Now())&"','删贴 ID:"&id&" Title:"&left(title,20)&" ','')")
						shuoming="【"&title&"】以及回复删除"
					End If 
					rs_u.close
				set rs_u=Nothing
				delTopic= "恭喜您！"&shuoming&"成功"&qian
				Call ActLog("主题操作：删除主题和回复<br>ID:"&id&" 标题:"&left(title,20)&"")
			Else
				delTopic="【"&title&"】不能重复删除！"
				Exit Function
			End If 
		Else
			delTopic="无权限，id="&id&"【"&title&"】未删除！"
		End If 
		rs.update
		rs.close
	set rs=Nothing
End Function 
'虚拟删除回复
'返回提示
Function delReBBS(id)
	'获取分类，判断权限。
	If IsAdmin<>9 Then 
		boardid=conn.execute("select "&bbstable&".boardid from "&rebbstable&","&bbstable&" where "&rebbstable&".re="&bbstable&".id and "&rebbstable&".id="&id&"")(0)
	End If 
	If CheckAdmin(boardid)>0 Then 
		'虚拟删除
		Set rs= Server.CreateObject("ADODB.Recordset")
			rs.Open "Select re,IsCheck,content From "&rebbstable&" where id="&id, conn,3,3  
			vdel_re=rs("re")
			content=rs("content")
			rs("IsCheck")=-1
			rs.update
			rs.close
		set rs=Nothing

		'读取该主题相关的帖子，用来更新主题
		Set rs= Server.CreateObject("ADODB.Recordset")
			rs.Open "Select * From "&rebbstable&" where re="&vdel_re&" and ischeck>-1 order by addtime desc", conn,1,1
			if rs.eof and rs.bof Then
				replynum=0
			Else
				replynum=rs.RecordCount
				rename=rs("username")
				retime=rs("addtime")
				lou=rs("lou")
			End If 
			rs.close
		set rs=Nothing
		'更新主题
		Set rs= Server.CreateObject("ADODB.Recordset")
			rs.Open "Select recount,retime,addtime,username,rename From "&bbstable&" where id="&vdel_re, conn,3,3
			rs("recount")=replynum
			If Int(replynum)<>0 Then 
				rs("retime")=retime
				rs("rename")=rename
			Else
				rs("retime")=rs("addtime")
				rs("rename")=rs("username")
			End If 
			rs.update
			rs.close
		set rs=Nothing
		'判断用户积分
		Set rs_u= Server.CreateObject("ADODB.Recordset")
			sql_u="Select "&rebbstable&".username as zuozhe,"&usertable&".username From "&rebbstable&","&usertable&" where "&usertable&".username="&rebbstable&".username and "&rebbstable&".id="&id
			rs_u.Open sql_u,conn,3,3
			if not rs_u.eof Then 
				username=rs_u("zuozhe")
				'判断删除帖子的是不是作者本人，若是，就扣相应添加的分，否则就是那个删除的分数
				If username=Dreamsun_name Then
					Sys_Del_Money_t=Sys_Re_Money
				Else
					Sys_Del_Money_t=Sys_Del_Money
				End If 
				conn.execute("update ["&usertable&"] set [umoney]=umoney-"&Sys_Del_Money_t&" where [username]='"&username&"'")
				OptTable("insert into [account] (accID,accValue,accFromUser,accToUser,accTime,accReason,accRemark) values("&CStr(GetMaxID("account","accid"))&","&CStr(Sys_Del_Money_t)&",'"&username&"','"&"系统"&"','"&CStr(Now())&"','删回贴 ID"&id&" Title:"&TitleLeft(content,20)&" ','')")
				qian=",扣除 "&username&" 积分"&Sys_Del_Money_t&"分"
			End If 
			rs_u.close
		set rs_u=Nothing
		delReBBS="恭喜您！【"&TitleLeft(Replace(content,vbCrLf,""),20)&"】删除成功!"&qian
		Call ActLog("主题操作：删除回复<br>ID:"&id&" 标题:"&TitleLeft(content,20)&"")
	Else
		delReBBS="<span class=hot>权限不够，reid="&id&"帖子尚未删除!</span>"
	End If 
End Function  

'板块置顶.返回提示.
Function IsTopTopic(id)
	Set rs= Server.CreateObject("ADODB.Recordset")
		rs.Open "Select title,istop,boardid From "&bbsTable&" where id="&id, conn,1,3
		title=rs("title")
		If CheckAdmin(rs("boardid"))>0 Then 
			rs("istop")=1
			IsTopTopic= "恭喜您！id="&id&",主题:【"&TitleLeft(title,30)&"】板块置顶成功"
			Call ActLog("主题操作:板块主题<br>ID:"&id&" 标题:"&TitleLeft(title,30)&"")
		Else
			IsTopTopic="您无权限，id="&id&"，主题：【"&title&"】 帖子板块置顶失败！"
		End If 
		rs.update
		rs.close
	set rs=Nothing
End Function 
'总置顶.返回提示.
Function IsTop2Topic(id)
	Set rs= Server.CreateObject("ADODB.Recordset")
		rs.Open "Select title,istop From "&bbsTable&" where id="&id, conn,1,3
		title=rs("title")
		If IsAdmin=9 Then 
			rs("istop")=2
			IsTop2Topic= "恭喜您！id="&id&",主题:【"&TitleLeft(title,30)&"】总置顶成功"
			Call ActLog("主题操作:总置顶主题<br>ID:"&id&" 标题:"&TitleLeft(title,30)&"")
		Else
			IsTop2Topic="您无权限，id="&id&"，主题：【"&title&"】 帖子总置顶失败！"
		End If 
		rs.update
		rs.close
	set rs=Nothing
End Function 
'取消置顶.返回提示.
Function NoIsTopTopic(id)
	Set rs= Server.CreateObject("ADODB.Recordset")
		rs.Open "Select title,istop,boardid From "&bbsTable&" where id="&id, conn,1,3
		title=rs("title")
		If rs("istop")=2 Then '总置顶的帖子取消置顶操作
			If IsAdmin=9 Then 
				rs("istop")=0
				NoIsTopTopic= "恭喜您！id="&id&",主题:【"&TitleLeft(title,30)&"】总置顶成功"
				Call ActLog("主题操作:总置顶主题<br>ID:"&id&" 标题:"&TitleLeft(title,30)&"")
			Else
				NoIsTopTopic="您无权限，id="&id&"，主题：【"&title&"】 帖子总置顶失败！"
			End If 
		ElseIf rs("istop")=1 Then '板块置顶的帖子取消置顶操作
			If CheckAdmin(rs("boardid"))>0 Then 
				rs("istop")=0
				NoIsTopTopic= "恭喜您！id="&id&",主题:【"&TitleLeft(title,30)&"】板块置顶成功"
				Call ActLog("主题操作:板块主题<br>ID:"&id&" 标题:"&TitleLeft(title,30)&"")
			Else
				NoIsTopTopic="您无权限，id="&id&"，主题：【"&title&"】 帖子板块置顶失败！"
			End If 
		End If 
		rs.update
		rs.close
	set rs=Nothing
End Function 
'审核主题.返回提示.
Function CheckTopic(id)
	Set rs= Server.CreateObject("ADODB.Recordset")
		rs.Open "Select title,IsCheck,boardid From "&bbsTable&" where id="&id, conn,1,3
		title=rs("title")
		If CheckAdmin(rs("boardid"))>0 Then 
			IsCheck=rs("IsCheck")
			If IsCheck=0 Then 
				rs("IsCheck")=1
				rs.update
				CheckTopic= "恭喜您！id="&id&",主题:【"&TitleLeft(title,30)&"】审核成功"
				Call ActLog("主题操作:审核主题<br>ID:"&id&" 标题:"&TitleLeft(title,30)&"")
			Else
				CheckTopic="【"&title&"】不能重复审核！"
				Exit Function
			End If 
		Else
			CheckTopic="您无权限，id="&id&"，主题：【"&title&"】 帖子审核失败！"
		End If 
		rs.close
	set rs=Nothing
End Function 
'屏蔽主题.返回提示.
Function NoCheckTopic(id)
	Set rs= Server.CreateObject("ADODB.Recordset")
		rs.Open "Select title,IsCheck,boardid From "&bbsTable&" where id="&id, conn,1,3
		title=rs("title")
		If CheckAdmin(rs("boardid"))>0 Then 
			IsCheck=rs("IsCheck")
			If IsCheck=1 Then 
				rs("IsCheck")=0
				NoCheckTopic= "恭喜您！id="&id&",主题:【"&TitleLeft(title,30)&"】屏蔽成功"
				Call ActLog("主题操作:屏蔽主题<br>ID:"&id&" 标题:"&TitleLeft(title,30)&"")
			Else
				NoCheckTopic="【"&title&"】不能重复屏蔽！"
				Exit Function
			End If 
		Else
			NoCheckTopic="您无权限，id="&id&"，主题：【"&title&"】 帖子屏蔽失败！"
		End If 
		rs.update
		rs.close
	set rs=Nothing
End Function 
'审核回复帖子 返回提示
Function CheckRe(id)
	'获取分类，判断权限。
	If IsAdmin<>9 Then 
		boardid=conn.execute("select "&bbstable&".boardid from "&rebbstable&","&bbstable&" where "&rebbstable&".re="&bbstable&".id and "&rebbstable&".id="&id&"")(0)
	End If 
	If CheckAdmin(boardid)>0 Then 
		'审核
		Set rs= Server.CreateObject("ADODB.Recordset")
			rs.Open "Select re,IsCheck,content From "&rebbstable&" where id="&id, conn,1,3  
			content=rs("content")
			rs("IsCheck")=1
			rs.update
			rs.close
		set rs=Nothing
		CheckRe="恭喜您！【"&TitleLeft(Replace(content,vbCrLf,""),20)&"】审核成功!"&qian
		Call ActLog("主题操作：审核回复<br>ID:"&id&" 标题:"&TitleLeft(content,20)&"")
	Else
		CheckRe="<span class=hot>权限不够，reid="&id&" 帖子尚未审核成功!</span>"
	End If 
End Function  
'屏蔽回复帖子 返回提示
Function NoCheckRe(id)
	'获取分类，判断权限。
	If IsAdmin<>9 Then 
		boardid=conn.execute("select "&bbstable&".boardid from "&rebbstable&","&bbstable&" where "&rebbstable&".re="&bbstable&".id and "&rebbstable&".id="&id&"")(0)
	End If 
	If CheckAdmin(boardid)>0 Then 
		'审核
		Set rs= Server.CreateObject("ADODB.Recordset")
			rs.Open "Select re,IsCheck,content From "&rebbstable&" where id="&id, conn,1,3  
			content=rs("content")
			rs("IsCheck")=0
			rs.update
			rs.close
		set rs=Nothing
		NoCheckRe="恭喜您！【"&TitleLeft(Replace(content,vbCrLf,""),20)&"】屏蔽成功!"&qian
		Call ActLog("主题操作：屏蔽回复<br>ID:"&id&" 标题:"&TitleLeft(content,20)&"")
	Else
		NoCheckRe="<span class=hot>权限不够，reid="&id&" 帖子尚未屏蔽成功!</span>"
	End If 
End Function  
'*************************************
' 精华操作
'*************************************
Function IsGoodSet(id)
	If id="" Or Not IsNumeric(id) Then Exit Function
	Set rs= Server.CreateObject("ADODB.Recordset")
		rs.Open "Select isgood,title,boardid From "&bbstable&" where id="&id, conn,1,3  
		If CheckAdmin(rs("boardid"))>0 Then 
			istops=rs("isgood")
			title=rs("title")
				If istops=0 Then
					rs("isgood")=1
					shuoming="设置精华"
					Set rs_u= Server.CreateObject("ADODB.Recordset")
						sql_u="Select "&bbstable&".username as zuozhe,"&usertable&".username From "&bbstable&","&usertable&" where "&usertable&".username="&bbstable&".username and "&bbstable&".id="&id
						rs_u.Open sql_u,conn,3,3
						if not rs_u.eof Then 
							username=rs_u("zuozhe")
							conn.execute("update ["&usertable&"] set [umoney]=umoney+"&Sys_Good_Money&" where [username]='"&username&"'")
							qian=","&username&" 获得积分"&Sys_Good_Money&"分"
							accFromUser = "系统"
							accToUser = username
							accReason = shuoming &" ID:"& id&" Title:"& title
							OptTable("insert into [account] (accID,accValue,accFromUser,accToUser,accTime,accReason,accRemark) values("&CStr(GetMaxID("account","accid"))&","&CStr(Sys_Good_Money)&",'"&accFromUser&"','"&accToUser&"','"&CStr(Now())&"','"&accReason&"','')")
						End If
						rs_u.close
					set rs_u=Nothing
				Else
					rs("isgood")=0
					shuoming="取消精华"
					Set rs_u= Server.CreateObject("ADODB.Recordset")
						sql_u="Select "&bbstable&".username as zuozhe,"&usertable&".username From "&bbstable&","&usertable&" where "&usertable&".username="&bbstable&".username and "&bbstable&".id="&id
						rs_u.Open sql_u,conn,3,3
						if not rs_u.eof Then 
							username=rs_u("zuozhe")
							conn.execute("update ["&usertable&"] set [umoney]=umoney-"&Sys_Good_Money&" where [username]='"&username&"'")
							qian=","&username&" 减去积分"&Sys_Good_Money&"分"
							accToUser = "系统"
							accFromUser = username
							accReason = shuoming &" ID:"& id&" Title:"& title
							OptTable("insert into [account] (accID,accValue,accFromUser,accToUser,accTime,accReason,accRemark) values("&CStr(GetMaxID("account","accid"))&","&CStr(Sys_Good_Money)&",'"&accFromUser&"','"&accToUser&"','"&CStr(Now())&"','"&accReason&"','')")
						End If 
						rs_u.close
					set rs_u=Nothing
					accFromUser = OptTable("select [username] from "&bbstable&" where id="&id) 'Add For V1.5
				End If 
				rs.update
				rs.close
			set rs=nothing
			set rs=nothing
			ActLog("主题操作："&shuoming&"<br>主题:"&left(title,20)&"")
			IsGoodSet="恭喜您！帖子"&shuoming&"成功"
		Else
			IsGoodSet="<span class=hot>权限不够，id="&id&"的帖子尚未操作成功</span>"
		End If 
End Function 
'*************************************
'格式化时间字符串
'*************************************
Function formattime(str)
if isnull(str) then exit function
formattime=FormatDateTime(str,2)&" "&FormatDateTime(str,4)&":00"
End Function
'*************************************
'缓存中读取Link
'*************************************
Function FriendLink()
	If Not IsArray(Application(webname&"_TieBa_Link")) Then GetLinkCache()
	if UBound(Application(webname&"_TieBa_Link"),1)=0 then TempStr=TempStr&"<dt>还没有分类</dt>":exit Function
	For k=0 To ubound(Application(webname&"_TieBa_Link"),2)
		TempStr=TempStr&"<dt><a href="""&Application(webname&"_TieBa_Link")(2,k)&""" target=blank>"&Application(webname&"_TieBa_Link")(1,k)&"</a></dt>"
	Next
	TempStr=TempStr&"<dt><a href=""h"&"t"&"t"&"p"&":"&"/"&"/"&"w"&"w"&"w"&"."&"8"&"8"&"r"&"e"&"n"&"w"&"u"&"."&"c"&"o"&"m"&""">"&"8"&"8"&"广"&"告"&"任"&"务"&"网"&"</a></dt>"
	FriendLink=TempStr
End Function 

'管理员操作记录功能。
Public Sub ActLog(str)
	Dim Temp,UserName
	UserName=Dreamsun_name
	If UserName="" Then UserName="-"
	Temp=Left(Request.ServerVariables("script_name")&"<br>"&Replace(Request.ServerVariables("Query_String"),"'","''"),255)
	OptTable("insert into ActLog (UserName,UserIP,Remark,LogTime,Geturl) values ('"&UserName&"','"&reip()&"','"&str&"','"&Now()&"','"&Temp&"')")
End Sub
'*************************************
'从网页中获得数据
'*************************************
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 "yem"
		DateToStr=Year(DateTime)&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"
	miStr = OptTable(miSql)
	if miStr="" then
		GetMaxID=1
	else
		'GetMaxID=CInt(miStr)+1
		'Edit By ZIDONE CHANG 2009/1/12
		GetMaxID=CLng(miStr)+1
	end if
End function
'*************************************
'换过滤脏话[包括色情/反动/宗教/恐怖等]
'*************************************
Function DropFuckWords(Content)
	bytes=split(Sys_BadWords,"|")
	for ii=0 to ubound(bytes)
	Content=replace(Content,trim(bytes(ii)),"***")
	Next
	DropFuckWords = Content
End Function 
'*************************************
'判断是否是广告帖
'返回 True/False
'Atrribute Add For V1.5 2007-11-11 CHANG,ZIDONE
'*************************************
Function IsAdTopic(str)
	IsAdTopic = False
	if right(Sys_ADWords,1)="|" then Sys_ADWords = left(Sys_ADWords,len(Sys_ADWords)-1)
	adFilterArr = Split(Sys_ADWords,"|")
	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
    For i = 1 To Len(str)
        c = LCase(Mid(str, i, 1))
        If InStr("$!<>?#^%@~`&*();:+='"" 	", c) > 0 Then
            IsKeptUser = False
            Exit Function
        End If
    Next
	if right(Sys_KeepName,1)="|" then Sys_KeepName = left(Sys_KeepName,len(Sys_KeepName)-1)
	keepUsernameArr = Split(Sys_KeepName,"|")
	For kuI = 0 to Ubound(keepUsernameArr)
		If InStr(str,keepUsernameArr(kuI))>0 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,t1)
	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
	If t1=1 Then If InStr(GetIpLocation," ")>0 Then GetIpLocation=Split(GetIpLocation," ")(0)
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= 2 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 > 2 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
'得到子分类分类的sql链接
Public Function GetBoardSonStr(Ast)
	If Not IsArray(Arr_Category) Then GetBoardCache()
	If IsArray(Arr_Category) Then
		For i=0 To Ubound(Arr_Category,2)
		IF Arr_Category(5,i)=Ast Then
			GetBoardSonStr= GetBoardSonStr &" or boardid="&Arr_Category(1,i)
		End IF
		Next
	End If
End Function
'得到分类的父分类
Public Function GetBoardFather(Ast)
	Dim i
	If Ast<1 then GetBoardFather="":Exit Function
	If Not IsArray(Arr_Category) Then GetBoardCache()
	If IsArray(Arr_Category) Then
		For i=0 To Ubound(Arr_Category,2)
		IF Arr_Category(1,i)=Ast Then
			GetBoardFather=Arr_Category(5,i)
			Exit For
		End IF
		Next
	End If
End Function
'得到分类的名字
Public Function GetBoardName(Ast)
	Dim i
	If Ast<1 then GetBoardName="":Exit Function
	If Not IsArray(Arr_Category) Then GetBoardCache()
	If IsArray(Arr_Category) Then
		For i=0 To Ubound(Arr_Category,2)
		IF Arr_Category(1,i)=Ast Then
			GetBoardName=Arr_Category(0,i)
			Exit For
		End IF
		Next
	End If
End Function
'*************************************
'通用调用函数
'*************************************
Function dylist(ltype,boardid,inson,num,titleLen,isblank,dytime,istime,istype)
	'ltype:列表类型，目前允许最新发表newPost,最新回复newRe,最多回复maxRe，最多阅读maxHits,精华文章good，top
	'boardid：分类，0为全部，否则为该分类。
	'inson：0或者1，如果为0，则不含子分类，否则含子分类。
	'num：调取条目，数字
	'titlelen：标题长度，意义不大，可以用css截取。
	'isblank：是否新窗口
	'istime:是否带着时间
	'istype:是否带着分类
	dylist=""
	Select Case ltype
		Case "newPost"
			orderby="order by b.addtime Desc,b.ID Desc"
		Case "newRe"'排除掉未曾回复的
			orderby="and b.recount>0 order by b.retime Desc,b.ID Desc"
		Case "maxRe"
			orderby="order by b.recount Desc,b.ID Desc"
		Case "maxHits"
			orderby="order by b.hits Desc,b.ID Desc"
		Case "good"
			orderby="and b.isgood=1 order by b.addtime Desc,b.ID Desc"
		Case "top"
			orderby="and b.istop>0 order by b.addtime Desc,b.ID Desc"
	End Select
	GetSonSqlStr=""
	tj=""
	If boardid<>0 Then
		If inson=1 Then GetSonSqlStr=GetBoardSonStr(BoardID)
		tj="and (boardid="&boardid&" "&GetSonSqlStr&" )"
	End If

	If isnull(num) or num="" then num=10
	If Not IsNumeric(num) Then num=10

	If isnull(titleLen) or titleLen="" then titleLen=10
	titleLen=Int(titleLen)
	title=""
	If isblank=1 Then inblank="target=_blank"
	set rs1=server.CreateObject("adodb.recordset")
		Rs1.open"select top "&num&" b.Id,b.title,b.addtime,b.boardid,t.board_name as boardname From "&bbstable&" as b,"&boardtable&" as t where b.boardid=t.board_id and b.ischeck=1 and DateDiff('d',b.addtime, now())<"&dytime&" "&tj&" and b.istop>-1 "&orderby&"",conn,1,1
		SQLQueryNums=SQLQueryNums+1
			if not rs1.eof then
				while not rs1.eof
					title=TitleLeft(trim(rs1("title")),titleLen)
					dylist=dylist&"<LI>"
					If istime=1 Then dylist=dylist&"<span><a><font color=""#cccccc"">-"&DateToStr(rs1("addtime"),"m-d") &"</font></a></span>"
					If istype=1 Then dylist=dylist&"[<a href=""Article.asp?boardid="&rs1("boardid")&""" class=tn>"&rs1("boardname")&"</a>] "
					dylist=dylist&"<A title="&rs1("title")&" href=""ShowNews.asp?id="&rs1("ID")&""" "&inblank&">"&title&"</A></LI>"
				Rs1.MoveNext
				wend
			else
				dylist=" <LI> 暂无信息</LI>"    
			end if
	   rs1.close
	   set rs1=nothing
End Function
'flash幻灯调用
Function picflash(swf_width,swf_height,swf_config,pic_files,pic_links,pic_texts)
	If swf_config="" Then swf_config="6|0xffffff|0x0099FF|50|0xffffff|0x0099FF|0x000000"
	'//config 设置分别为: 自动播放时间(秒)|文字颜色|文字背景色|文字背景透明度|按键数字色|当前按键色|普通按键色
	TempStr=TempStr & "<script type=""text/javascript"">"
	TempStr=TempStr & "var swf_width="&swf_width&";"
	TempStr=TempStr & "var swf_height="&swf_height&";"
	TempStr=TempStr & "var config='"&swf_config&"';"
	TempStr=TempStr & "var files="""&pic_files&""";"
	TempStr=TempStr & "var links="""&pic_links&""";"
	TempStr=TempStr & "var texts="""&pic_texts&""";"
	TempStr=TempStr & "document.write('<object classid=""clsid:d27cdb6e-ae6d-11cf-96b8-444553540000"" codebase=""http://fpdownload.macromedia.com/pub/shockwave/cabs/flash/swflash.cab#version=6,0,0,0"" width=""'+ swf_width +'"" height=""'+ swf_height +'"">');"
	TempStr=TempStr & "document.write('<param name=""movie"" value=""images/focus.swf"" />');"
	TempStr=TempStr & "document.write('<param name=""quality"" value=""high"" />');"
	TempStr=TempStr & "document.write('<param name=""menu"" value=""false"" />');"
	TempStr=TempStr & "document.write('<param name=wmode value=""opaque"" />');"
	TempStr=TempStr & "document.write('<param name=""FlashVars"" value=""config='+config+'&bcastr_flie='+files+'&bcastr_link='+links+'&bcastr_title='+texts+'"" />');"
	TempStr=TempStr & "document.write('<embed src=""images/focus.swf"" wmode=""opaque"" FlashVars=""config='+config+'&bcastr_flie='+files+'&bcastr_link='+links+'&bcastr_title='+texts+'"" menu=""false"" quality=""high"" width=""'+ swf_width +'"" height=""'+ swf_height +'"" type=""application/x-shockwave-flash"" pluginspage=""http://www.macromedia.com/go/getflashplayer"" />');"
	TempStr=TempStr & "document.write('</object>');"
	TempStr=TempStr & "</script>"
picflash=TempStr
End Function 
Function GetPicFlash(BoardID)
If BoardID="" Or BoardID=0 Then 
	sqlStr=""
Else
	sqlStr=" and boardid="&BoardID&" "
End If 
	set rs1=server.CreateObject("adodb.recordset")
		Rs1.open"select top 5 Id,title,picurl From "&bbstable&" where ischeck=1 and picurl<>'http://' and picurl<>'' "&sqlStr&" order by addtime Desc,id desc",conn,1,1
		if not rs1.eof then
			while not rs1.eof
				title_array=title_array&trim(TitleLeft(rs1("title"),36))&"|"
				pic_array=pic_array&trim(rs1("picurl"))&"|"
				id_array=id_array&"ShowNews.asp?id="&trim(rs1("ID"))&"|"
			Rs1.MoveNext
			wend
		else
			title_array="暂无图片"
			pic_array="images/nopic.jpg"
			id_array="1"
		end If
		If right(title_array,1)="|" Then title_array=Left(title_array,len(title_array)-1)
		If right(id_array,1)="|" Then id_array=Left(id_array,len(id_array)-1)
		If right(pic_array,1)="|" Then pic_array=Left(pic_array,len(pic_array)-1)
	rs1.close 
	Set rs1=Nothing
'判断是否存在边栏宽度，如果不存在，就放弃。
	skininfo=getTemplate("ddp_skin")
	If InStr(skininfo,"|")>0 Then 
		skininfoarray=Split(skininfo,"|")
		sidebar_is=skininfoarray(1)
		sidebar_kuan=skininfoarray(2)
	End If
	If sidebar_is Then 
		SideBarHight=sidebar_kuan*0.8
		GetPicFlash=picflash(sidebar_kuan,SideBarHight,"",""&pic_array&"",""&id_array&"",""&title_array&"")
	End If 
End Function 
'远程存图函数
Function ReplaceRemoteUrl(t0,t1,t2,t3,t4)
	ddp_upfiledir="upload/"
	't0是内容。
	't1为限制文件大小,为0时不限制
	't2为限制的文件类型
	't3为是否水印,只有系统开启水印才生效
	't4用户id，考虑到安全，为空不允许上传。
	If t4="" Or Not IsNumeric(t4) Then 
		ReplaceRemoteUrl = sHtml 
		Exit Function
	End If 
	sHtml = t0
	IF t2="" Then t2="gif|jpg|png|bmp"
	t6=ddp_upfiledir&Year(Now())&Right("0"&Month(Now()),2)&"/"

	Set objRegExp = New Regexp'设置配置对象  
	objRegExp.IgnoreCase = True'忽略大小写  
	objRegExp.Global = True'设置为全文搜索  
	objRegExp.Pattern = "\[img.*?\]http://([\s\S]*?)\[\/img\]" 

	sHtml=trim(sHtml)  
	Set Matches =objRegExp.Execute(sHtml)'开始执行配置  
	baseUrl = "http://" & Request.ServerVariables("HTTP_HOST") 
	For Each Match in Matches
	tPicUrl=""
	tPicUrl=Match.submatches(0)
	If tPicUrl<>"" Then
		tPicUrl="http://"&tPicUrl
		If InStr(RetStr,tPicUrl)=0 Then '去掉重复的。 
			If InStr (tPicUrl,baseUrl)=0 Then '去掉本地的。
				RetStr = RetStr &tPicUrl&"||"
				SaveFileType = Mid(tPicUrl, InstrRev(tPicUrl, ".") + 1)
				 '是否允许远程存图的格式。
				If InStr(t2,SaveFileType)>0 Then
					isSave=True 
				Else
					isSave=False
					ReplaceRemoteUrl = sHtml 
					Exit Function
				End If
				'获取大小
				'ReplaceRemoteUrl=tPicUrl

				Set oXMLHTTP = CreateObject("MSXML2.ServerXMLHTTP")
				oXMLHTTP.open "GET",tPicUrl,False
				oXMLHTTP.send
				GetRemoteData=oXMLHTTP.responsebody
				Set oXMLHTTP=Nothing

				'判断大小
				IF Clng(t1)>0 Then
					If Clng(t1)>Clng(Round(LenB(GetRemoteData)/1024)) Then
						isSave=True 
					Else
						isSave=False
						ReplaceRemoteUrl = sHtml 
						Exit Function
					End If
				End If
				If isSave Then
					Randomize
					sRnd = Int(9000 * Rnd) + 1000
					'重新命名图片
					SaveFileName = DateToStr(Now(), "YmdHIS")&sRnd&"_"&t4&"."&SaveFileType
					'保存图片
					Set Ads=Server.CreateObject("a"&"do"&"db"&"."&"s"&"t"&"r"&"ea"&"m")
					With Ads
						.Type = 1
						.Open
						.Write GetRemoteData
						.SaveToFile Server.MapPath(t6&SaveFileName), 2
						.Cancel()
						.Close()
					End With
					Set Ads=Nothing
					If Err.Number=0 Then sHtml=replace(sHtml,tPicUrl,t6&SaveFileName)
				End If 
			End If 
		End If 
	End If
	Next  
	ReplaceRemoteUrl = sHtml 
End Function 
'*************************************
'站长加油站 专用页码简化版,取得显示页码
'*************************************
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
		If Dreamsun_cls<>"" And Left(Dreamsun_cls,1)<>"&" Then Dreamsun_cls="&"&Dreamsun_cls
			   viewpage=viewpage& "<div class=""meneame""><em>&nbsp;" & p_c &"/&nbsp;"&p_y&"</em> "
               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& "<strong>"& p_m &"</strong>"
			   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& "<input type=""text"" name=""custompage"" size=""3"" onkeydown=""if(event.keyCode==13) {window.location='"&showfile&"?abc=1"&Dreamsun_cls&"&amp;CurPage='+this.value; return false;}""/></div>"& vbCrLf
End Function
%>