dv_ubbcode.asp

公司企业网站管理系统全站源码正式免费版

				Select Case NodeName
					Case "object"
						If AttName = "data" Then
							node.removeAttribute AttName
						End If
					Case "param"
						If Cint(Board_Setting(9) * mt)=0 Then
							hasname=0
							hasvalue=0
							If AttName="name" and Attribute.text = "autostart" Then
								hasname=1
							ElseIf AttName = "value" Then
								If hasvalue=1 Then
									node.setAttribute AttName,"false"
								End If
							End If
						End If
					Case "embed"				
						If Cint(Board_Setting(9) * mt)=0 Then
							If AttName="autoplay" Then
								node.setAttribute AttName,"false"
							ElseIf AttName = "title" Then
								If Attribute.text<>UBB_TITLE Then
									node.setAttribute "title",UBB_TITLE
								End If
							ElseIf AttName = "src" Then
								node.setAttribute "src",Attribute.text
							Else
								'node.removeAttribute AttName
							End If
						End If

				End Select				
			Next

		Next

		Dim i

		'改掉所有的id属性避免造成混乱
		'For Each Node in xml.documentElement.selectNodes("//@id")
		'	node.text="dv_ubb_"& node.text
		'Next
		'For Each Node in xml.documentElement.selectNodes("//@name")
		'	node.text="dv_ubb_"& node.text
		'Next
		If instr(","& can_Post_Style &",",","& PostUserGroup &",") = 0 Then
			For Each Node in xml.documentElement.selectNodes("//@*")
				If LCase(Node.nodeName)="style" Then
					Stylestr=node.text
					Stylestr=split(Stylestr,";")
					newstyle=""
				 	For each style in Stylestr
				 		style1=split(style,":")
				 		If UBound(style1)>0 Then
				 			style_a=LCase(Trim(style1(0)))
					 		style_b=LCase(Trim(style1(1)))
					 		If UBound(style1)>1 Then
					 				For i =2 to UBound(style1)
					 				style_b=style_b& ":"& style1(i)
					 				Next
					 		End If
					 		'吃掉POSITION:,top,left几个属性
					 		If (style_a<>"top" and style_a<>"left" and style_a<>"bottom" and style_a<>"right" and style_a<>"" and style_a<> "position") Then
						 			'去掉过宽的属性
						 			If style_a="width" Then
						 				If InStr(style_b,"px")>0 Then
						 					style_b=replace(style_b,"px","")
						 					If IsNumeric(style_b) Then
						 						If CLng(style_b)>600 Then style_b=600
						 					End If
						 					style_b=style_b&"px"
						 				ElseIf InStr(style_b,"%")>0 Then
						 					style_b=replace(style_b,"%","")
						 					If IsNumeric(style_b) Then
						 						If CLng(style_b)>100 Then style_b=100
						 					End If
						 					style_b=style_b&"%"
						 			End If
					 				'去掉过大的字体
						 			If style_a = "font-size" Then
						 				If InStr(style_b,"px")>0 Then
						 					style_b=replace(style_b,"px","")
						 					If IsNumeric(style_b) Then
						 						If CLng(style_b)> 200 Then style_b=200
						 					End If
						 					style_b=style_b&"px"
						 				ElseIf InStr(style_b,"%")> 0 Then
						 					style_b=replace(style_b,"%","")
						 					If IsNumeric(style_b) Then
						 						If CLng(style_b)>100 Then style_b=100
						 					End If
						 					style_b=style_b&"%"
						 				End If
						 			End If
					 			End If 
					 			newstyle=newstyle&style_a&":"&style_b&";"
					 		End If
				 		End If
					Next
					node.text=newstyle
				End If
			Next
		End If
		checkXHTML=replace(Mid(xml.documentElement.xml,6,Len (xml.documentElement.xml)-11),"&amp;","&")
	End Function
	Function checkimg(textstr)
		Dim node,titletext
		If xml.loadxml("<div>" & replace(textstr,"&","&amp;") &"</div>")Then
			For Each Node in xml.documentElement.getElementsByTagName("img")
				Set titletext=node.attributes.getNamedItem("title")
				If titletext is nothing Then
					titletext=""
				Else
					titletext=titletext.text
				End If 
				If titletext=UBB_TITLE Then
					Rem 是否开启滚轮改变图片大小的功能，如果不需要可以屏蔽
					Rem Node.attributes.setNamedItem(xml.createNode(2,"onmousewheel","")).text="return bbimg(this);"
					Node.attributes.setNamedItem(xml.createNode(2,"onload","")).text="imgresize(this);"
					Node.attributes.setNamedItem(xml.createNode(2,"alt","")).text="图片点击可在新窗口打开查看"	
				Else
					Rem 是否开启滚轮改变图片大小的功能，如果不需要可以屏蔽
					Rem Node.attributes.setNamedItem(xml.createNode(2,"onmousewheel","")).text="return bbimg(this);"
					Node.attributes.setNamedItem(xml.createNode(2,"onload","")).text="imgresize(this);"
					Node.attributes.setNamedItem(xml.createNode(2,"style","")).text="cursor: pointer;"
					Node.attributes.setNamedItem(xml.createNode(2,"alt","")).text="图片点击可在新窗口打开查看"
					Node.attributes.setNamedItem(xml.createNode(2,"onclick","")).text="javascript:window.open(this.src);"
					If Not node.parentNode is Nothing Then
						If node.parentNode.nodename = "a" Then
								node.attributes.removeNamedItem("onclick")
						End If
					End If
				End If
			Next
			checkimg=replace(Mid(xml.documentElement.xml,6,Len (xml.documentElement.xml)-11),"&amp;","&")
		Else
			checkimg=textstr
		End If
	End Function
	Rem 字符转换
	Private Function replaceasc(strText)
		Dim s,match,po,i
		s=replace(strText,"&amp;","&")
		If InStr(s,"\")=0 And InStr(s,"&#")=0 Then
			replaceasc=LCase(strText)
			Exit Function
		End If
		re.Pattern="(&#x)([0-9|a-z]{1,2})"
		Set match = re.Execute(s)
		For i= 0 to  match.count -1
			po=re.Replace(match.item(i),"$2")
			po="&H"+po
			If IsNumeric(po) Then
				s=Replace(s,match.item(i),Chr(po))
			End If
		Next
		re.Pattern="(&#0*)"
		s=re.Replace(s,"&#")
		re.Pattern="&#([0-9]{1,3})"
		Set match = re.Execute(s)
		For i= 0 to  match.count -1
			po=re.Replace(match.item(i),"$1")
			s=Replace(s,"&#"&po&";",Chr(po))
			s=Replace(s,"&#"&po&"",Chr(po))
		Next
		re.Pattern="(\\0*)"
		s=re.Replace(s,"\")
		re.Pattern="(\\)([0-9|a-z]{1,2})"
		Set match = re.Execute(s)
		For i= 0 to  match.count -1
			po=re.Replace(match.item(i),"$2")
			po="&H"+po
			If IsNumeric(po) Then
				s=Replace(s,match.item(i),Chr(po))
			End If
		Next
		s=replace(s,Chr(13),"")
		s=replace(s,Chr(10),"")
		s=replace(s,Chr(9),"")
		s=replace(s,"/*","")
		s=replace(s,"*/","")
		replaceasc=LCase(replace(s,Chr(0),""))
	End Function
	Private Function bbimg(strText)
		Dim s
		s=strText
		re.Pattern="<img(.[^>]*)([/| ])>"
		s=re.replace(s,"<img$1/>")
		If InStr(Ubblists,",40,")=0 Then
			re.Pattern="<img(.[^>]*)/>"
			s=re.replace(s,"<img$1 onload=""imgresize(this);""/>")
		End If
		bbimg=s
	End Function
	'签名UBB转换
	Public Function Dv_SignUbbCode(s,PostUserGroup)
		Dim ii
		Dim po
		If Dvbbs.forum_setting(66)="0" Then
			s= server.htmlEncode(s)
			re.Pattern="\[\/(img|dir|qt|mp|rm|sound|flash)\]"
			If re.Test(s) Then
				If Dv_FilterJS2(s)Then
					re.Pattern="\[(br)\]"
					s=re.Replace(s,"<$1>")
					re.Pattern = "(&nbsp;)"
					s = re.Replace(s,Chr(9))
					re.Pattern = "(<br/>)"
					s = re.Replace(s,vbNewLine)
					re.Pattern = "(<br />)"
					s = re.Replace(s,vbNewLine)
					re.Pattern = "(<p>)"
					s = re.Replace(s,"")
					re.Pattern = "(<\/p>)"
					s = re.Replace(s,vbNewLine)
					s=server.htmlencode(s)
					s="<form name=""scode"&replyid&""" method=""post"" action=""""><table class=""tableborder2"" cellspacing=""1"" cellpadding=""3"" width=""100%"" align=""center"" border=""0""><tr><th height=""22"">以下内容含脚本,或可能导致页面不正常的代码</th></tr><tr><td class=""tablebody1"" align=""middle"" width=""98%""><textarea id=""CodeText"" style=""BORDER-RIGHT: 1px dotted; BORDER-TOP: 1px dotted; OVERFLOW-Y: visible; OVERFLOW: visible; BORDER-LEFT: 1px dotted; WIDth: 98%; COLOR: #000000; BORDER-BOTTOM: 1px dotted"" rows=""20"" cols=""120"">"&s&"</textarea></td></tr><tr><td class=""tablebody2"" align=""middle"" width=""98%""><b>说明：</b>上面显示的是代码内容。您可以先检查过代码没问题，或修改之后再运行.</td></tr><tr><td class=""tablebody1"" align=""middle"" width=""98%""><input type=""button"" name=""run"" value=""运行代码"" onclick=""Dvbbs_ViewCode("&replyid&");""></td></tr></table></form>"
					s = Replace(s, vbNewLine, "")
					s = Replace(s, Chr(10), "")
					s = Replace(s, Chr(13), "")
					Dv_SignUbbCode=s
					Exit Function
				End If
			End If
			re.Pattern="([^"&Chr(13)&"])"& Chr(10)
			s= re.Replace(s,"$1<br />")
			re.Pattern=Chr(13)&Chr(10)&"(.*)" 
			s= re.Replace(s,"<p>$1</p>")
		Else
				If Dv_FilterJS(s) Then
					re.Pattern="\[(br)\]"
					s=re.Replace(s,"<$1>")
					re.Pattern = "(&nbsp;)"
					s = re.Replace(s,Chr(9))
					re.Pattern = "(<br/>)"
					s = re.Replace(s,vbNewLine)
					re.Pattern = "(<br>)"
					s = re.Replace(s,vbNewLine)
					re.Pattern = "(<p>)"
					s = re.Replace(s,"")
					re.Pattern = "(<\/p>)"
					s = re.Replace(s,vbNewLine)
					s=server.htmlencode(s)
					s="<form name=""scode"&replyid&""" method=""post"" action=""""><table class=""tableborder2"" cellspacing=""1"" cellpadding=""3"" width=""100%"" align=""center"" border=""0""><tr><th height=""22"">以下内容含脚本,或可能导致页面不正常的代码</th></tr><tr><td class=""tablebody1"" align=""middle"" width=""98%""><textarea id=""CodeText"" style=""BORDER-RIGHT: 1px dotted; BORDER-TOP: 1px dotted; OVERFLOW-Y: visible; OVERFLOW: visible; BORDER-LEFT: 1px dotted; WIDth: 98%; COLOR: #000000; BORDER-BOTTOM: 1px dotted"" rows=""20"" cols=""120"">"&s&"</textarea></td></tr><tr><td class=""tablebody2"" align=""middle"" width=""98%""><b>说明：</b>上面显示的是代码内容。您可以先检查过代码没问题，或修改之后再运行.</td></tr><tr><td class=""tablebody1"" align=""middle"" width=""98%""><input type=""button"" name=""run"" value=""运行代码"" onclick=""Dvbbs_ViewCode("&replyid&");""></td></tr></table></form>"
					Dv_SignUbbCode=s
					Exit Function
				End If
			re.Pattern="<((asp|\!|%))"
			s=re.Replace(s,"&lt;$1")
			re.Pattern="(>)("&vbNewLine&")(<)"
			s=re.Replace(s,"$1$3") 
			re.Pattern="(>)("&vbNewLine&vbNewLine&")(<)"
			s=re.Replace(s,"$1$3") 
		End If
		s = Replace(s, "  ", "&nbsp;&nbsp;")