⭐ 欢迎来到虫虫下载站！ | 📦 资源下载 📁 资源专辑 ℹ️ 关于我们
⭐ 虫虫下载站
📤 上传资源

📄 cl_function_collect.asp

📁 正版创力4.1SQL商业版!!!ASP版。
💻 ASP
📖 第 1 页 / 共 5 页
字号:
🔍
12345 
				If Right(consulturl,1)="/" Then
					If Right(lcase(primitiveurl),3)=".cn" Or Right(lcase(primitiveurl),3)="com" Or Right(lcase(primitiveurl),3)="net" Or Right(lcase(primitiveurl),3)="org" Then
						Definiteurl="http:\\" & Primitiveurl & "/"
					Else
						Definiteurl=consulturl & Primitiveurl
					End If
				Else
					If Right(lcase(primitiveurl),3)=".cn" Or Right(lcase(primitiveurl),3)="com" Or Right(lcase(primitiveurl),3)="net" Or Right(lcase(primitiveurl),3)="org" Then
						Definiteurl="http:\\" & Primitiveurl & "/"
					Else
						Definiteurl=left(consulturl,instrrev(consulturl,"/")) & "/" & Primitiveurl
					End If
				End If
			Else
				If Right(consulturl,1)="/" Then
					Definiteurl=consulturl & Primitiveurl & "/"
				Else
					Definiteurl=left(consulturl,instrrev(consulturl,"/")) & "/" & Primitiveurl & "/"
				End If			
			End If
		End If
	End If
	If Left(definiteurl,1)="/" Then
	Definiteurl=right(definiteurl,len(definiteurl)-1)
	End If
	If Definiteurl<>"" Then
		Definiteurl=replace(definiteurl,"//","/")
		Definiteurl=replace(definiteurl,":\\","://")
	Else
		Definiteurl="$False$"
	End If
End Function

'==================================================
'函数名：fphtmlencode
'作  用：标题过滤
'参  数：fstring ------字符串
'==================================================
Function Fphtmlencode(fstring)
	If Isnull(fstring)=False Or Fstring<>"" Or Fstring<>"$False$" Then
		Fstring=Cl.nohtml(fstring)
		Fstring=filterjs(fstring)
		Fstring = Replace(fstring,"&nbsp;"," ")
		Fstring = Replace(fstring,"&quot;","")
		Fstring = Replace(fstring,"&#39;","")
		Fstring = Replace(fstring, ">", "")
		Fstring = Replace(fstring, "<", "")
		Fstring = Replace(fstring, Chr(9), " ")'&nbsp;
		Fstring = Replace(fstring, Chr(10), "")
		Fstring = Replace(fstring, Chr(13), "")
		Fstring = Replace(fstring, Chr(34), "")
		Fstring = Replace(fstring, Chr(32), " ")'space
		Fstring = Replace(fstring, Chr(39), "")
		Fstring = Replace(fstring, Chr(10) & Chr(10),"")
		Fstring = Replace(fstring, Chr(10)&chr(13), "")
		Fstring=Trim(fstring)
		Fphtmlencode=fstring
	Else
		Fphtmlencode="$False$"
	End If
End Function

'==================================================
'函数名：Getpaing
'作  用：获取分页
'==================================================
Function Getpaing(byval Constr,startstr,overstr,inclul,inclur)
If Constr="$False$" Or Constr="" Or Startstr="" Or Overstr="" Or Isnull(constr)=True Or Isnull(startstr)=True Or Isnull(overstr)=True Then
	Getpaing="$False$"
	Exit Function
End If

Dim Start,over,contemp,Tempstr
Tempstr=lcase(constr)
Startstr=lcase(startstr)
Overstr=lcase(overstr)
Over=instr(1,Tempstr,overstr)
If Over<=0 Then
	Getpaing="$False$"
	Exit Function
Else
	If Inclur=True Then
		Over=over+len(overstr)
	End If
End If
Tempstr=mID(Tempstr,1,over)
Start=instrrev(Tempstr,startstr)
If Inclul=False Then
	Start=start+len(startstr)
End If

If Start<=0 Or Start>=over Then
	Getpaing="$False$"
	Exit Function
End If
Contemp=mID(constr,start,over-start)

Contemp=Trim(contemp)
Contemp=replace(contemp," ","")
Contemp=replace(contemp,",","")
Contemp=replace(contemp,"'","")
Contemp=replace(contemp,"""","")
Contemp=replace(contemp,">","")
Contemp=replace(contemp,"<","")
Contemp=replace(contemp,"&nbsp;","")
Getpaing=contemp
End Function

'==================================================
'函数名：scripthtml
'作  用：过滤html标记
'参  数：constr ------ 要过滤的字符串
'==================================================
Function Scripthtml(byval Constr,tagName,ftype)
	Dim Re
	Set Re=new Regexp
	Re.ignorecase =True
	Re.global=True
	Select Case Ftype
	Case 1
		Re.Pattern="<" & TagName & "([^>])*>"
		Constr=re.replace(constr,"")
	Case 2
		Re.Pattern="<" & TagName & "([^>])*>.*?</" & TagName & "([^>])*>"
		Constr=re.replace(constr,"") 
	Case 3
		Re.Pattern="<" & TagName & "([^>])*>"
		Constr=re.replace(constr,"")
		Re.Pattern="</" & TagName & "([^>])*>"
		Constr=re.replace(constr,"")
	End Select
	Scripthtml=constr
	Set Re=Nothing
End Function

'**************************************************
'函数名：createkeyword
'作  用：由给定的字符串生成关键字
'参  数：constr---要生成关键字的原字符串
'返回值：生成的关键字
'**************************************************
Function Createkeyword(byval Constr,num)
	If Constr="" Or Isnull(constr)=True Or Constr="$False$" Then
		Createkeyword="$False$"
		Exit Function
	End If
	If Num="" Or Isnumeric(num)=False Then
		Num=2
	End If
	Constr=replace(constr,chr(32),"")
	Constr=replace(constr,chr(9),"")
	Constr=replace(constr,"&nbsp;","")
	Constr=replace(constr," ","")
	Constr=replace(constr,"(","")
	Constr=replace(constr,")","")
	Constr=replace(constr,"<","")
	Constr=replace(constr,">","")
	Constr=replace(constr,"""","")
	Constr=replace(constr,"?","")
	Constr=replace(constr,"*","")
	Constr=replace(constr,"|","")
	Constr=replace(constr,",","")
	Constr=replace(constr,".","")
	Constr=replace(constr,"/","")
	Constr=replace(constr,"\","")
	Constr=replace(constr,"-","")
	Constr=replace(constr,"@","")
	Constr=replace(constr,"#","")
	Constr=replace(constr,"$","")
	Constr=replace(constr,"%","")
	Constr=replace(constr,"&","")
	Constr=replace(constr,"+","")
	Constr=replace(constr,":","")
	Constr=replace(constr,"：","")	
	Constr=replace(constr,"‘","")
	Constr=replace(constr,"“","")
	Constr=replace(constr,"”","")
	Constr=replace(constr,"&","")  
	Constr=replace(constr,"gt;","")		
	Dim I,constrtemp
	For I=1 To Len(constr)
		Constrtemp=constrtemp & "|" & MID(constr,i,num)
	Next
	If Len(constrtemp)<254 Then
		Constrtemp=constrtemp & "|"
	Else
		Constrtemp=left(constrtemp,254) & "|"
	End If
	Constrtemp=left(constrtemp,len(constrtemp)-1)
	Constrtemp= Right(constrtemp,len(constrtemp)-1)
	Createkeyword=constrtemp
End Function

Function Checkurl(strurl)
	Dim Re
	Set Re=new Regexp
	Re.ignorecase =True
	Re.global=True
	Re.Pattern="http://([\w-]+\.)+[\w-]+(/[\w-./?%&=]*)?"
	If Re.test(strurl)=True Then
		Checkurl=strurl
	Else
		Checkurl="$False$"
	End If
	Set Rs=Nothing
End Function

Function GetItemID(ItemID,itemsType) '选择采集
	Dim ItemIDstr,ItemID_ID : ItemID_ID=split(ItemID,",")  
	For I=1 To Ubound(ItemID_ID)
			If I=1 Then 
				ItemIDstr=ItemID_ID(i)
			Else
				ItemIDstr=ItemIDstr & "," & ItemID_ID(i)
			End If
	Next
	If ItemsType=0 Then GetItemID=ItemID_ID(0)	Else GetItemID=ItemIDstr End If
End Function

Function Ubbcode(byval Strcontent)
	Dim Imagepath
	Dim Emotimagepath
	Imagepath=Cl.webdir & "images/"
	Emotimagepath=Cl.webdir & "images/emot"
	Strcontent= Filterjs(strcontent)
	Dim Re
	Dim Po,ii
	Dim Recontent
	Set Re=new Regexp
	Re.ignorecase =True
	Re.global=True
	Po=0
	Ii=0

	Re.Pattern="\[img\](.)\[\/img\]"
	Strcontent=re.replace(strcontent,"<img Src='$1' Border=0>")
		
	Re.Pattern="\[img\](http|https|ftp):\/\/(.[^\[]*)\[\/img\]"
	Strcontent=re.replace(strcontent,"<a Onfocus=this.blur() Href=""$1://$2"" TarGet=_blank><img Src=""$1://$2"" Border=0 Alt=按此在新窗口浏览图片 Onload=""javascript:if(this.wIDth>screen.wIDth-333)this.wIDth=screen.wIDth-333""></a>")
	Re.Pattern="\[upload=(gif|jpg|jpeg|bmp|png)\](.[^\[]*)(gif|jpg|jpeg|bmp|png)\[\/upload\]"
	Strcontent= Re.replace(strcontent,"<br><img Src="""&imagepath&"$1.gif"" Border=0>此主题相关图片如下：<br><a Href=""$2$1"" TarGet=_blank><img Src=""$2$1"" Border=0 Alt=按此在新窗口浏览图片 Onload=""javascript:if(this.wIDth>screen.wIDth-333)this.wIDth=screen.wIDth-333""></a>")

	Re.Pattern="\[upload=(.[^\[]*)\](.[^\[]*)\[\/upload\]"
	Strcontent= Re.replace(strcontent,"<br><img Src="""&imagepath&"$1.gif"" Border=0> <a Href="""& Strinstalldir & Channeldir & "/$2"">点击浏览该文件</a>")

	Re.Pattern="\[dir=*([0-9]*),*([0-9]*)\](.[^\[]*)\[\/dir]"
	Strcontent=re.replace(strcontent,"<object ClassID=clsID:166b1bca-3f9c-11cf-8075-444553540000 Codebase=http://download.macromedia.com/pub/shockwave/cabs/director/sw.cab#version=7,0,2,0 WIDth=$1 Height=$2><param Name=src Value=$3><embed Src=$3 Pluginspage=http://www.macromedia.com/shockwave/download/ WIDth=$1 Height=$2></embed></object>")
	Re.Pattern="\[qt=*([0-9]*),*([0-9]*)\](.[^\[]*)\[\/qt]"
	Strcontent=re.replace(strcontent,"<embed Src=$3 WIDth=$1 Height=$2 Autoplay=True Loop=False Controller=True Playeveryframe=False Cache=False Scale=tofit Bgcolor=#000000 Kioskmode=False TarGetcache=False Pluginspage=http://www.apple.com/quicktime/>")
	Re.Pattern="\[mp=*([0-9]*),*([0-9]*)\](.[^\[]*)\[\/mp]"
	Strcontent=re.replace(strcontent,"<object Align=mIDdle ClassID=clsID:22d6f312-b0f6-11d0-94ab-0080c74c7e95 Class=object ID=mediaplayer WIDth=$1 Height=$2 ><param Name=Showstatusbar Value=-1><param Name=fileName Value=$3><embed Type=application/x-oleobject Codebase=http://activex.microsoft.com/activex/controls/mplayer/en/nsmp2inf.cab#version=5,1,52,701 FleName=mp Src=$3  WIDth=$1 Height=$2></embed></object>")
	Re.Pattern="\[rm=*([0-9]*),*([0-9]*)\](.[^\[]*)\[\/rm]"
	Strcontent=re.replace(strcontent,"<object ClassID=clsID:cfcdaa03-8be4-11cf-b84b-0020afbbccfa Class=object ID=raocx WIDth=$1 Height=$2><param Name=src Value=$3><param Name=console Value=clip1><param Name=controls Value=imagewindow><param Name=autostart Value=True></object><br><object ClassID=clsID:cfcdaa03-8be4-11cf-b84b-0020afbbccfa Height=32 ID=vIDeo2 WIDth=$1><param Name=src Value=$3><param Name=autostart Value=-1><param Name=controls Value=controlpanel><param Name=console Value=clip1></object>")

	Re.Pattern="(\[flash\])(.[^\[]*)(\[\/flash\])"
	Strcontent= Re.replace(strcontent,"<a Href=""$2"" TarGet=_blank><img Src=" & Imagepath & "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=5,0,0,0 ClassID=clsID:d27cdb6e-ae6d-11cf-96b8-444553540000 WIDth=500 Height=400><param Name=movie Value=""$2""><param Name=quality Value=high><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=400>$2</embed></object>")

	Re.Pattern="(\[flash=*([0-9]*),*([0-9]*)\])(.[^\[]*)(\[\/flash\])"
	Strcontent= Re.replace(strcontent,"<a Href=""$4"" TarGet=_blank><img Src=" & Imagepath & "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=5,0,0,0 ClassID=clsID:d27cdb6e-ae6d-11cf-96b8-444553540000 WIDth=$2 Height=$3><param Name=movie Value=""$4""><param Name=quality Value=high><embed Src=""$4"" 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</embed></object>")

	Re.Pattern="(\[url\])(.[^\[]*)(\[\/url\])"
	Strcontent= Re.replace(strcontent,"<a Href=""$2"" TarGet=_blank>$2</a>")
	Re.Pattern="(\[url=(.[^\[]*)\])(.[^\[]*)(\[\/url\])"
	Strcontent= Re.replace(strcontent,"<a Href=""$2"" TarGet=_blank>$3</a>")

	Re.Pattern="(\[email\])(\s+\@.[^\[]*)(\[\/email\])"
	Strcontent= Re.replace(strcontent,"<img Align=absmIDdle Src=" & Imagepath & "email1.gif><a Href=""mailto:$2"">$2</a>")
	Re.Pattern="(\[email=(\s+\@.[^\[]*)\])(.[^\[]*)(\[\/email\])"
	Strcontent= Re.replace(strcontent,"<img Align=absmIDdle Src=" & Imagepath & "email1.gif><a Href=""mailto:$2"" TarGet=_blank>$3</a>")

	'自动识别网址
	're.Pattern = "^((http|https|ftp|rtsp|mms):(\/\/|\\\\)[a-za-z0-9\./=\?%\-&_~`@':+!]+)"
	'strcontent = Re.replace(strcontent,"<img Align=absmIDdle Src=pic/url.gif Border=0><a TarGet=_blank Href=$1>$1</a>")
	're.Pattern = "((http|https|ftp|rtsp|mms):(\/\/|\\\\)[a-za-z0-9\./=\?%\-&_~`@':+!]+)$"
	'strcontent = Re.replace(strcontent,"<img Align=absmIDdle Src=pic/url.gif Border=0><a TarGet=_blank Href=$1>$1</a>")
	're.Pattern = "([^>=""])((http|https|ftp|rtsp|mms):(\/\/|\\\\)[a-za-z0-9\./=\?%\-&_~`@':+!]+)"
	'strcontent = Re.replace(strcontent,"$1<img Align=absmIDdle Src=pic/url.gif Border=0><a TarGet=_blank Href=$2>$2</a>")

	'自动识别www等开头的网址
	're.Pattern = "([^(http://|http:\\)])((www|cn)[.](\w)+[.]{1,}(net|com|cn|org|cc)(((\/[\~]*|\\[\~]*)(\w)+)|[.](\w)+)*(((([?](\w)+){1}[=]*))*((\w)+){1}([\&](\w)+[\=](\w)+)*)*)"
	'strcontent = Re.replace(strcontent,"<img Align=absmIDdle Src=pic/url.gif Border=0><a TarGet=_blank Href=http://$2>$2</a>")

	'自动识别email地址，如打开本功能在浏览内容很多的帖子会引起服务器停顿
	're.Pattern = "([^(=)])((\w)+[@]{1}((\w)+[.]){1,3}(\w)+)"
	'strcontent = Re.replace(strcontent,"<img Align=absmIDdle Src=pic/url.gif Border=0><a TarGet=_blank Href=""mailto:$2"">$2</a>")

	Re.Pattern="\[em(.[^\[]*)\]"
	Strcontent=re.replace(strcontent,"<img Src="&emotimagepath&"em$1.gif Border=0 Align=mIDdle>")

	Re.Pattern="\[html\](.[^\[]*)\[\/html\]"
	Strcontent=re.replace(strcontent,"<table WIDth='100%' Border='0' Cellspacing='0' Cellpadding='6' Class=tableborder1><td><b>以下内容为程序代码:</b><br>$1</td></table>")
	Re.Pattern="\[code\](.[^\[]*)\[\/code\]"
	Strcontent=re.replace(strcontent,"<table WIDth='100%' Border='0' Cellspacing='0' Cellpadding='6' Class=tableborder1><td><b>以下内容为程序代码:</b><br>$1</td></table>")

	Re.Pattern="\[color=(.[^\[]*)\](.[^\[]*)\[\/color\]"
	Strcontent=re.replace(strcontent,"<font Color=$1>$2</font>")
	Re.Pattern="\[face=(.[^\[]*)\](.[^\[]*)\[\/face\]"
	Strcontent=re.replace(strcontent,"<font Face=$1>$2</font>")
	Re.Pattern="\[align=(center|left|right)\](.*)\[\/align\]"
	Strcontent=re.replace(strcontent,"<div Align=$1>$2</div>")

	Re.Pattern="\[quote\](.*)\[\/quote\]"
	Strcontent=re.replace(strcontent,"<table Style=""wIDth:80%"" Cellpadding=5 Cellspacing=1 Class=tableborder1><tr><td Class=tableborder1>$1</td></tr></table><br>")
	Re.Pattern="\[fly\](.*)\[\/fly\]"
	Strcontent=re.replace(strcontent,"<marquee WIDth=90% Behavior=alternate Scrollamount=3>$1</marquee>")
	Re.Pattern="\[move\](.*)\[\/move\]"
	Strcontent=re.replace(strcontent,"<marquee Scrollamount=3>$1</marquee>")	
	Re.Pattern="\[glow=*([0-9]*),*(#*[a-z0-9]*),*([0-9]*)\](.[^\[]*)\[\/glow]"
	Strcontent=re.replace(strcontent,"<table WIDth=$1 Style=""filter:glow(color=$2, Strength=$3)"">$4</table>")
	Re.Pattern="\[shadow=*([0-9]*),*(#*[a-z0-9]*),*([0-9]*)\](.[^\[]*)\[\/shadow]"
	Strcontent=re.replace(strcontent,"<table WIDth=$1 Style=""filter:shadow(color=$2, Strength=$3)"">$4</table>")

	Re.Pattern="\[i\](.[^\[]*)\[\/i\]"
	Strcontent=re.replace(strcontent,"<i>$1</i>")
	Re.Pattern="\[u\](.[^\[]*)(\[\/u\])"
	Strcontent=re.replace(strcontent,"<u>$1</u>")
	Re.Pattern="\[b\](.[^\[]*)(\[\/b\])"
	Strcontent=re.replace(strcontent,"<b>$1</b>")
	Re.Pattern="\[size=([1-7])\](.[^\[]*)\[\/size\]"
	Strcontent=re.replace(strcontent,"<font Size=$1>$2</font>")
	Strcontent=replace(strcontent,"<i></i>","")
	Set Re=Nothing
	Ubbcode=strcontent
End Function

Function Filterjs(byval V)
	If Isnull(v) Or Trim(v)="" Then
		Filterjs=""
		Exit Function
	End If

	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 Function

Function Dvhtmlencode(byval Fstring)
	If Isnull(fstring) Or Trim(fstring)="" Then
		Dvhtmlencode=""
		Exit Function
	End If
	Fstring = Replace(fstring, ">", "&gt;")
	Fstring = Replace(fstring, "<", "&lt;")

	Fstring = Replace(fstring, Chr(32), "&nbsp;")
	Fstring = Replace(fstring, Chr(9), "&nbsp;")
	Fstring = Replace(fstring, Chr(34), "&quot;")
	Fstring = Replace(fstring, Chr(39), "&#39;")
	Fstring = Replace(fstring, Chr(13), "")
	Fstring = Replace(fstring, Chr(10) & Chr(10), "</p><p> ")
	Fstring = Replace(fstring, Chr(10), "<br> ")

	Dvhtmlencode = Fstring
End Function

Function Dvhtmlcode(byval Fstring)
	If Isnull(fstring) Or Trim(fstring)="" Then
		Dvhtmlcode=""
		Exit Function
	End If
	Fstring = Replace(fstring, "&gt;", ">")
	Fstring = Replace(fstring, "&lt;", "<")
12345

⌨️ 快捷键说明

复制代码 Ctrl + C
搜索代码 Ctrl + F
全屏模式 F11
切换主题 Ctrl + Shift + D
显示快捷键 ?
增大字号 Ctrl + =
减小字号 Ctrl + -