ubbcode.asp

一个asp写的论坛源代码,论坛所需要的功能都有

<%
	'**************************************************
	'函数名：UBB_Code
	'作  用：UBB代码转换
	'参  数：str   ----需转换的字符
	'返回值：转换后的字符
	'**************************************************
	Function UBB_Code(Str)
		If Str="" Or IsNull(Str) Then Exit Function
		Dim s,re,r
		set re = New RegExp
		re.Global = True
		re.IgnoreCase = True
		s = str
		If InStr(s,"payto:") = 0 Then
			s = Replace(s,"https://www.alipay.com/payt","https://www.alipay.com/payto:")
		End If
		s=TM_Alipay_PayTo(s)
		re.Pattern="\[code\](.*?)\[\/code\]"
		s=re.Replace(s,"<b>CODE:</b><div class=""code"">"&Server.HtmlEncode("$1")&"</div>")
		'RM-UBB
		re.Pattern="\[RM=*([0-9]*),*([0-9]*),*([true|false]*)\](.[^\[]*)\[\/RM]"
		s=re.Replace(s,"<object classid=""clsid:CFCDAA03-8BE4-11cf-B84B-0020AFBBCCFA"" class=""object"" id=""RAOCX"" width=""$1"" height=""$2""><param name=""SRC""value=""$4""><param name=""CONSOLE"" value=""$4""><param name=""CONtrOLS"" value=""imagewindow""><param name=""AUTOSTART"" value=""$3"" ></object><br/><object classid=""CLSID:CFCDAA03-8BE4-11CF-B84B-0020AFBBCCFA"" height=""32"" id=""video"" width=""$1""><param name=""SRC""value=""$4""><param name=""AUTOSTART"" value=""$3""><param name=""CONtrOLS"" value=""controlpanel""><param name=""CONSOLE"" value=""$4""></object>")
		'MP-UBB
		re.Pattern="\[MP=*([0-9]*),*([0-9]*),*([true|false]*)\](.[^\[]*)\[\/MP]"
		s=re.Replace(s,"<object align='middle' classid='CLSID:22d6f312-b0f6-11d0-94ab-0080c74c7e95' class='OBJECT' id='MediaPlayer' width='$1' height='$2'><PARAM NAME='AUTOSTART' VALUE='$3'><param name='ShowStatusBar' value=-1><param name=Filename value=$4><embed type=application/x-oleobject codebase='http://activex.microsoft.com/activex/controls/mplayer/en/nsmp2inf.cab#Version=5,1,52,701' flename='mp' src='$4' width='$1' height='$2'></embed></object>")	
		'FLASH
		re.Pattern="(\[FLASH=*([0-9]*),*([0-9]*)\])(http://|ftp://|../)(.[^\[]*)(\[\/FLASH\])"
		If team.Forum_setting(69) = 1 Then
			s= re.Replace(s,"<a href=""$4$5"" TARGET=""_blank""><IMG SRC=""images/type/swf.gif"" border=""0"" alt=""点击开新窗口欣赏该FLASH动画!"" height=""16"" width=""16"">[全屏欣赏]</a><br><OBJECT codeBase=""http://download.macromedia.com/pub/shockwave/cabs/flash/swflash.cab#version=4,0,2,0"" classid=""clsid:D27CDB6E-AE6D-11cf-96B8-444553540000"" width=""$2"" height=""$3""><PARAM NAME=""movie"" VALUE=""$4$5""><PARAM NAME=""quality"" VALUE=""high""><embed src=""$4$5"" quality=""high"" pluginspage=""http://www.macromedia.com/shockwave/download/index.cgi?P1_Prod_Version=ShockwaveFlash"" type=""application/x-shockwave-flash"" width=""$2"" height=""$3"">$4$5</embed></OBJECT>")
		Else
			s= re.Replace(s,"<a href=""$4$5"" TARGET=""_blank""><IMG SRC=""images/type/swf.gif"" border=""0"" align=""bsmiddle"" height=""16"" width=""16"">[全屏欣赏,注意Flash可能含有不安全内容]</a>")
		End If
		If Not Request("newpage")="edit" Then
			s = b2html(s)
			re.Pattern="\[UPLOAD=(gif|jpg|jpeg|bmp|png)\](.*?)\[\/UPLOAD]"
			If team.Forum_setting(69) = 1 Then
				s=re.Replace(s,"<BR><A HREF=""$2"" TARGET=_blank><IMG SRC=""$2"" border=0 alt=""按此在新窗口浏览图片""  onmouseover=""javascript:if(this.width>520)this.width=520;"" style=""CURSOR: hand"" onload=""javascript:if(this.width>520)this.width=520;""'></A>")
			Else
				s=re.Replace(s,"<BR><A HREF=""$2"" TARGET=_blank><IMG SRC=""images/type/$1.gif"" border=0 alt=""按此在新窗口浏览图片""></A>")
			End If
			If team.Forum_setting(69) = 1 Then
				re.Pattern="\[img\]\s*([^\[\<\r\n]+?)\s*\[\/img\]"
				s=re.Replace(s,"<img src=""$1"" border=""0"" onload=""if(this.width>screen.width*0.7) {this.resized=true; this.width=screen.width*0.7; this.alt='Click here to open new window\\nCTRL+Mouse wheel to zoom in/out';}"" onmouseover=""if(this.width>screen.width*0.7) {this.resized=true; this.width=screen.width*0.7; this.style.cursor='hand'; this.alt='Click here to open new window\\nCTRL+Mouse wheel to zoom in/out';}"" onclick=""if(!this.resized) {return true;} else {window.open('$1');}"" onmousewheel=""return imgzoom(this);"" alt="""" />")
				re.Pattern="\[img=(\d{1,3})[x|\,](\d{1,3})\]\s*([^\[\<\r\n]+?)\s*\[\/img\]"
				s=re.Replace(s,"<img width=""$1"" height=""$2"" src=""$3"" border=""0"" alt="""" />")
			Else
				re.Pattern="\[img\]\s*([^\[\<\r\n]+?)\s*\[\/img\]"
				s=re.Replace(s,"<a href=""$1"" target=""_blank"">$1</a>")
				re.Pattern="\[img=(\d{1,3})[x|\,](\d{1,3})\]\s*([^\[\<\r\n]+?)\s*\[\/img\]"
				s=re.Replace(s,"<a href=""$1"" target=""_blank"">$1</a>")
			End If
			re.Pattern="\[UPLOAD=(txt|rar|zip)\]([0-9]*)\[\/UPLOAD]"
			If team.Group_Browse(24) = 0 Then 
				s=re.Replace(s,"<img src=""images/type/$1.gif"" border=""0"" align=""absmiddle""> 您所在的组没有查看附件的权限。")
			Else
				s=re.Replace(s,"<img src=""images/type/$1.gif"" border=""0"" align=""absmiddle""><A HREF=""ShowFile.asp?ID=$2"" TARGET=""_blank"">点击浏览该文件</A>")
			End If
			re.Pattern="\[UPLOAD=(swf|swi)\](.*?)\[\/UPLOAD]"
			If team.Forum_setting(14) = 1 Then
				s=re.Replace(s,"<img src=""images/type/$1.gif"" border=""0"" align=""absmiddle""><br><embed src=""$2"" quality=high pluginspage='http://www.macromedia.com/shockwave/download/index.cgi?P1_Prod_Version=ShockwaveFlash' type='application/x-shockwave-flash' width=500 height=300></embed>")
			Else
				s=re.Replace(s,"<img src=""images/type/$1.gif"" border=""0"" align=""absmiddle""><A HREF=""$2"" TARGET=""_blank"">[全屏欣赏,注意Flash可能含有不安全内容]</A>")
			End if
			re.Pattern="\[UPLOAD=(.[^\[]*)\]([0-9]*)\[\/UPLOAD]"
			s=re.Replace(s,"<img src=""images/type/$1.gif"" border=""0"" align=""absmiddle""><A HREF=""ShowFile.asp?ID=$2"" TARGET=""_blank"">点击浏览该文件</A>")
			If Instr(s,"[REPLAYVIEW]")>0 or Instr(s,"[replayview]")>0 Then
				Dim Uid,CodeRs
				UID=int(Request.QueryString("tid"))
				Set CodeRs = team.Execute("Select UserName,Relist,Replies From Forum Where ID="& UID )
				IF Not CodeRs.Eof And Request.QueryString("retopicid")="" Then
					re.Pattern="\[REPLAYVIEW\][\s\n]*\[\/REPLAYVIEW\]"
					s=re.Replace(s,"")
					re.Pattern="\[\/REPLAYVIEW\]"
					s=re.replace(s, chr(1)&"/REPLAYVIEW]")
					re.Pattern="\[REPLAYVIEW\]([^\x01]*)\x01\/REPLAYVIEW\]"
					If Not team.UserLoginED Then 
						s=re.Replace(s,"<fieldset class=textquote><legend><strong>回复可见贴</strong></legend>本帖内容已被隐藏,请登陆后查看!</fieldset>")
					Else
						If tk_UserName = CodeRs(0) or team.ManageUser Or Team.Execute("Select Count(ID) From "&CodeRs(1)&" Where Topicid="&UID&" And UserName='"&TK_UserName&"'")(0)>0  Then
							s=re.Replace(s,"<fieldset class=textquote><legend><strong>回复可见贴</strong></legend>$1</fieldset>")
						Else
							s=re.Replace(s,"<fieldset class=textquote><legend><strong>回复可见贴</strong></legend>本帖内容已被隐藏,回复本帖后才可查看!</fieldset>")
						End If
					End if
				End If
			End If
		End if
		UBB_Code=ChkBadWords(s)
		Set re = Nothing
	End Function
	'签名用UBB
	Function Sign_Code(Str,a)
		If Str="" Or IsNull(Str) Then Exit Function
		Dim s,re
		s = Str
		Set re=new RegExp		
		re.IgnoreCase =true
		re.Global=True
		s=Replace(s,"<BR>","<br>")
		s=Replace(s,"</P><P>","</p><p>")
		s=Replace(s,"&lt;","&lt")
		s=Replace(s,"&nbsp;","&nbsp")
		If Int(a) = 0 Then
			Sign_Code = s
			Exit Function
		End if
		re.Pattern="\[marquee\](.*?)\[\/marquee]"
		s=re.Replace(s,"<marquee width=90% behavior=alternate scrollamount=""3"">$1</marquee>")
		re.Pattern="\[font=([^<>\]]*?)\](.*?)\[\/font]"
		s=re.Replace(s,"<font face=""$1"">$2</font>")
		re.Pattern="\[color=([^<>\]]*?)\](.*?)\[\/color]"
		s=re.Replace(s,"<font color=""$1"">$2</font>")
		re.Pattern="\[align=([^<>\]]*?)\](.*?)\[\/align]"
		s=re.Replace(s,"<div align=""$1"">$2</div>")
		re.Pattern="\[size=(\d*?)\](.*?)\[\/size]"
		s=re.Replace(s,"<font size=""$1"">$2</font>")
		re.Pattern="\[b\](.*?)\[\/b]"
		s=re.Replace(s,"<strong>$1</strong>")
		re.Pattern="\[p\](.*?)\[\/p]"
		s=re.Replace(s,"<p>$1</p>")
		re.Pattern="\[strike\](.*?)\[\/strike]"
		s=re.Replace(s,"<strike>$1</strike>")
		re.Pattern="\[li\](.*?)\[\/li]"
		s=re.Replace(s,"<li>$1</li>")
		re.Pattern="\[s\](.*?)\[\/s]"
		s=re.Replace(s,"<s>$1</s>")	
		re.Pattern="\[i\](.*?)\[\/i]"
		s=re.Replace(s,"<em>$1</em>")	
		re.Pattern="\[u\](.*?)\[\/u]"
		s=re.Replace(s,"<u>$1</u>")
		re.Pattern="\[p\](.*?)\[\/p]"
		s=re.Replace(s,"<p>$1</p>")
		re.Pattern="\[sub\](.*?)\[\/sub]"
		s=re.Replace(s,"<sub>$1</sub>")	
		re.Pattern="\[sup\](.*?)\[\/sup]"
		s=re.Replace(s,"<sup>$1</sup>")
		re.Pattern="\[glow\](.*?)\[\/glow]"
		s=re.Replace(s,"<span style='behavior:url(inc/font.htc)'>$1</span>")
		re.Pattern="\[qq\](\d*?)\[\/qq]"
		s=re.Replace(s,"<a target=blank href=http://wpa.qq.com/msgrd?V=1&Uin=$1&Site=team5.cn&Menu=yes><img border=""0"" SRC=http://wpa.qq.com/pa?p=1:$1:5 alt=""点击这里给我发消息""></a>")
		re.Pattern="\[URL\](.*?)\[\/URL]"
		s=re.Replace(s,"<A HREF=""$2"" TARGET=_blank>$2</A>")
		re.Pattern="(\[URL=(.[^\[]*)\])(.*?)(\[\/URL\])"
		s= re.Replace(s,"<A HREF=""$2"" TARGET=_blank>$3</A>")
		re.Pattern="\[IMG\](.*?)\[\/IMG]"
		s=re.Replace(s,"<IMG SRC=""$1"" border=0>")
		re.Pattern="\[QUOTE\](.*?)\[\/QUOTE]"
		s=re.Replace(s,"<div class=""quote"">$1</div>")
		Sign_Code=ChkBadWords(s)
		Set re = Nothing
	End Function

	Private Function TM_Alipay_PayTo(strText)
		If Not Isnull(strText) Then
			Dim s,ss,re
			Dim match,match2,urlStr,re2
			Dim t(2),temp,check,fee,i,encode8_tmp
			s=strText
			Set re=new RegExp
			re.IgnoreCase =true
			re.Global=true
			Set re2=new RegExp
			re2.IgnoreCase =true
			re2.Global=False
			t(0)="卖家承担运费"
			t(1)="买家承担运费"
			t(2)="虚拟物品不需邮递"
			s=strText
			re.Pattern="\[\/payto\]"
			s=re.replace(s, chr(1)&"/payto]")
			re.Pattern="\[payto\]([^\x01]+)\x01\/payto\]"
			Set match = re.Execute(s)
			re.Global=False
			For i=0 To match.count-1
				re2.Pattern="\(seller\)([^\n]+?)\(\/seller\)"
				If re2.Test(match.item(i)) Then
					Set match2 = re2.Execute(match.item(i))
					temp=re2.replace(match2.item(0),"$1")
					ss=""
					urlStr="API/payto.asp?seller="&temp
					re2.Pattern="\(subject\)([^\n]+?)\(\/subject\)"
					If re2.Test(match.item(i)) Then
						Set match2 = re2.Execute(match.item(i))
						temp=re2.replace(match2.item(0),"$1")
						ss=ss&"<div class=code><br/><b>商品名称</b>："&temp&"<br/><br/>"
						urlStr = urlStr & "&subject=" & Server.UrlEncode(temp)
						re2.Pattern="\(body\)((.|\n)*?)\(\/body\)"
						If re2.Test(match.item(i)) Then
							Set match2 = re2.Execute(match.item(i))
							temp=re2.replace(match2.item(0),"$1")
							ss=ss&"<b>商品说明</b>："&temp&"<br/><br/>"
							urlStr = urlStr & "&body=" & Server.UrlEncode(Cutstr(temp,200))
							re2.Pattern="\(price\)([\d\.]+?)\(\/price\)"
							If re2.Test(match.item(i)) Then
								Set match2 = re2.Execute(match.item(i))
								temp=re2.replace(match2.item(0),"$1")
								ss=ss&"<b>商品价格</b>："&temp&" 元<br/><br/>"
								urlStr=urlStr&"&price="&temp
								re2.Pattern="\(transport\)([1-3])\(\/transport\)"
								If re2.Test(match.item(i)) Then
									Set match2 = re2.Execute(match.item(i))
									temp=re2.replace(match2.item(0),"$1")
									check=true
									If int(temp)=2 Then
										re2.Pattern="\(express_fee\)([\d\.]+?)\(\/express_fee\)"
										If re2.Test(match.item(i)) Then
											Set match2 = re2.Execute(match.item(i))
											fee=re2.replace(match2.item(0),"$1")
											ss=ss&"<b>邮递信息</b>："&t(temp-1)&"，快递 "&fee&" 元<br/><br/>"
											urlStr=urlStr&"&transport="&temp&"&express_fee="&fee
										Else
											re2.Pattern="\(ordinary_fee\)([\d\.]+?)\(\/ordinary_fee\)"
											If re2.Test(match.item(i)) Then
												Set match2 = re2.Execute(match.item(i))
												fee=re2.replace(match2.item(0),"$1")
												ss=ss&"<b>邮递信息</b>："&t(temp-1)&"，平邮 "&fee&" 元<br/><br/>"
												urlStr=urlStr&"&transport="&temp&"&ordinary_fee="&fee
											Else
												check=False
											End If
										End If
									Else
										ss=ss&"<b>邮递信息</b>："&t(temp-1)&"<br/><br/>"
										urlStr=urlStr&"&transport="&temp
									End If
									If check=true Then
										check=False
										re2.Pattern="\(ww\)([^\n]+?)\(\/ww\)"