www.gusucode.com > 全球营销软件站整站源码4月最新数据 4.0源码程序 > 801wyxqf\adminadmin\asked\ubbcode.asp

    <%
'禁用UBB标签
Const UBB_ENABLE_AUTO_URL = True
Const UBB_ENABLE_IMG = True
Const UBB_ENABLE_URL = True
Const UBB_ENABLE_FONT = True

Function UBBCode(ByVal strContent)
	If IsNull(strContent) Or strContent = "" Then
		UBBCode = ""
		Exit Function
	End If
	Dim re
	Set re=New RegExp
	re.IgnoreCase=True
	re.Global=True
	
	If UBB_ENABLE_IMG Then
		If InStr(Lcase(strContent),"[/img]")>0 Then
			re.Pattern="(\[img\])(.[^\[]*)(\[\/img\])"
			strContent=re.Replace(strContent,"<img src=""$2""/>")
		End If
	End If
	If UBB_ENABLE_URL Then
		re.Pattern = "\[url=(.[^\]]*)\](.[^\[]*)\[\/url]"
		strContent=re.Replace(strContent,"<a target=""_blank"" href=""$1"">$2</a>")
		re.Pattern = "\[url](.[^\[]*)\[\/url]"
		strContent=re.Replace(strContent,"<a target=""_blank"" href=""$1"">$1</a>")
	End If
	If UBB_ENABLE_FONT Then
		If InStr(Lcase(strContent),"[/align]")>0 Then
			re.Pattern="\[align=(\w{4,6})\]([^\r]*?)\[\/align\]"
			strContent=re.Replace(strContent,"<div align=""$1"">$2</div>")
		End If
		re.Pattern="\[color=(#\w{3,10}|\w{3,10})\]([^\r]*?)\[\/color\]"
		strContent=re.Replace(strContent,"<span style=""color:$1"">$2</span>")
		re.Pattern="\[size=(\d{1,2})\]([^\r]*?)\[\/size\]"
		strContent=re.Replace(strContent,"<span style=""font-size:$1pt"">$2</span>")
		re.Pattern="\[font=([^\r]*?)\]([^\r]*?)\[\/font\]"
		strContent=re.Replace(strContent,"<span style=""font-family:$1"">$2</span>")
		re.Pattern="\[b\]([^\r]*?)\[\/b\]"
		strContent=re.Replace(strContent,"<strong>$1</strong>")
		re.Pattern="\[i\]([^\r]*?)\[\/i\]"
		strContent=re.Replace(strContent,"<i>$1</i>")
		re.Pattern="\[u\]([^\r]*?)\[\/u\]"
		strContent=re.Replace(strContent,"<u>$1</u>")
		re.Pattern="\[s\]([^\r]*?)\[\/s\]"
	End If
	re.Pattern="(<s+cript[^>]*?>([\w\W]*?)<\/s+cript>)":strContent=re.Replace(strContent, "")
	re.Pattern="(<iframe[^>]*?>([\w\W]*?)<\/iframe>)":strContent=re.Replace(strContent, "")
	re.Pattern="(on(load|click|dbclick|mouseover|mouseout|mousedown|mouseup|mousewheel|keydown|submit|change|focus)=""[^""]+"")"
	strContent=re.Replace(strContent, "")
	re.Pattern="(on(load|click|dbclick|mouseover|mouseout|mousedown|mouseup|mousewheel|keydown|submit|change|focus)='[^""]+')"
	strContent=re.Replace(strContent,"")
	re.Pattern="<img(\w*) style\s*=""*([^>|""]*)""([^>]*)>"
	strContent=re.Replace(strContent,"<img$1$3>")
	re.Pattern="<img(.[^>]*)>"
	strContent=re.Replace(strContent, "<img$1/>")
	re.Pattern="(\/\/>)"
	strContent=re.Replace(strContent, "/>")
	re.Pattern="<img(.[^>]*)([/| ])>"
	strContent=re.Replace(strContent,"<img$1/>")
	re.Pattern="<img(.[^>]*)/>"
	strContent=re.Replace(strContent,"<img$1 onload=""resizeme(this)"" onclick=""javascript:window.open(this.src);"" style=""cursor:pointer;""/>")
	If UBB_ENABLE_AUTO_URL Then
		'自动识别网址
		re.Pattern="(^|[^<>=""'\]])((http|https|ftp|rtsp|mms|ed2k):(\/\/|\\\\)(([\w\/\\\+\-~`@:%\/\|])+\.)+([\w\/\\\.\=\?\+\-~`@\':!%#\/\|]|(&amp;))+)"
		strContent=re.Replace(strContent,"$1<a target=""_blank"" href=""$2"">$2</a>")
		'自动识别www等开头的网址
		're.Pattern="(^|[^\/\\\w\=])((www|bbs)\.(\w)+\.([\w\/\\\.\=\?\+\-~`@\'!%#]|(&amp;))+)"
		'strContent=re.Replace(strContent,"$1<a target=""_blank"" href=""http://$2"">$2</a>")
	End If
	Set re=Nothing
	UBBCode=strContent
End Function

Function UBB2Html(ByVal strContent)
	If IsNull(strContent) Or strContent = "" Then
		UBB2Html = ""
		Exit Function
	End If
	strContent = TrimNewline(strContent)
	strContent = Replace(strContent, Chr(0), "")
	strContent = Replace(strContent, "&", "&amp;")
	strContent = Replace(strContent, ">", "&gt;")
	strContent = Replace(strContent, "<", "&lt;")
	strContent = Replace(strContent, Chr(32), " ")
	strContent = Replace(strContent, Chr(9), " ")
	strContent = Replace(strContent, "  ", "　")
	strContent = Replace(strContent, Chr(34), "&quot;")
	strContent = Replace(strContent, Chr(39), "&#39;")
	strContent = Replace(strContent, Chr(13), "")
	'strContent = Replace(strContent, Chr(10) & Chr(10), "</p><p>")
	strContent = Replace(strContent, Chr(10), "<br/>")
	strContent = Replace(strContent, "</p><p>", "</p>" & vbCrLf & "<p>")
	UBB2Html = "<p>" & strContent & "</p>"
End Function

Function Html2UBB(ByVal strContent)
	If IsNull(strContent) Or strContent = "" Then
		Html2UBB = ""
		Exit Function
	End If
	strContent = Replace(strContent, Chr(0), "")
	Dim re
	Set re = New RegExp
	re.IgnoreCase = True
	re.Global = True
	re.Pattern = "([\f\n\r\t\v])"
	strContent = re.Replace(strContent,"")
	re.Pattern = "(on(load|click|dbclick|mouseover|mousedown|mouseup|mousewheel|keydown)=""[^""]+"")":strContent = re.Replace(strContent, "")
	re.Pattern = "(on(load|click|dbclick|mouseover|mousedown|mouseup|mousewheel|keydown)=\'[^""]+\')":strContent = re.Replace(strContent, "")
	re.Pattern = "(<s+cript[^>]*?>([\w\W]*?)<\/s+cript>)":strContent = re.Replace(strContent, "")
	re.Pattern = "(<a[^>]+href=""([^""]+)""[^>]*>(.*?)<\/a>)":strContent = re.Replace(strContent, Chr(10)&"[url=$2]$3[/url]"&Chr(10))
	re.Pattern = "(<font[^>]+color=""([^"">]+)""[^>]*>(.*?)<\/font>)":strContent = re.Replace(strContent, Chr(10)&"[color=$2]$3[/color]"&Chr(10))
	re.Pattern = "(<font[^>]+color=([^ >]+)[^>]*>(.*?)<\/font>)":strContent = re.Replace(strContent, Chr(10)&"[color=$2]$3[/color]"&Chr(10))
	re.Pattern = "(<p[^>]+align=""([^"">]+)""[^>]*>(.*?)<\/p>)":strContent = re.Replace(strContent, "[align=$2]$3[/align]")
	re.Pattern = "(<p[^>]+align=([^"">]+)[^>]*>(.*?)<\/p>)":strContent = re.Replace(strContent, "[align=$2]$3[/align]")
	re.Pattern = "(<img[^>]+src=""([^""]+)""[^>]*>)":strContent = re.Replace(strContent, Chr(10)&"[img]$2[/img]"&Chr(10))
	re.Pattern = "(<img[^>]+src='([^""]+)'[^>]*>)":strContent = re.Replace(strContent, Chr(10)&"[img]$2[/img]"&Chr(10))
	re.Pattern = "(<img[^>]+src=([^""]+)[^>]*>)":strContent = re.Replace(strContent, Chr(10)&"[img]$2[/img]"&Chr(10))
	re.Pattern = "(<([\/]?)strong>)":strContent = re.Replace(strContent, "[$2b]")
	re.Pattern = "(<([\/]?)b>)":strContent = re.Replace(strContent, "[$2b]")
	re.Pattern = "(<([\/]?)u>)":strContent = re.Replace(strContent, "[$2u]")
	re.Pattern = "(<([\/]?)i>)":strContent = re.Replace(strContent, "[$2i]")
	re.Pattern = "(<([\/]?)p>)":strContent = re.Replace(strContent, Chr(10)&"$1"&Chr(10))
	re.Pattern = "(<br[^>]*?>)":strContent = re.Replace(strContent, Chr(10))
	re.Pattern = "((<p>&nbsp;</p>)|(<p></p>))":strContent = re.Replace(strContent, Chr(10))
	re.Pattern = "((<p[^>]*?>)|(</p>))":strContent = re.Replace(strContent, Chr(10))
	re.Pattern = "(<[^>]*?>)":strContent = re.Replace(strContent, "")
	Set re = Nothing
	Html2UBB = TrimNewline(strContent)
End Function

Function TrimNewline(ByVal strContent)
	If IsNull(strContent) Then
		TrimNewline = ""
		Exit Function
	End If
	strContent = Replace(strContent, Chr(13), "")
	If strContent = "" Then
		TrimNewline = ""
		Exit Function
	End If
	If Left(strContent,1) = Chr(10) Then
		strContent = Replace(strContent, Chr(10), vbNullString, 1, 1)
		strContent = TrimNewline(strContent)
	End If
	If Right(strContent,1) = Chr(10) Then
		strContent = Left(strContent,Len(strContent)-1)
		strContent = TrimNewline(strContent)
	End If
	TrimNewline = strContent
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
%>