function.asp

这个就是受到众人喜爱的许愿墙了

<%
	'==================================================
	'函数名：GetHttpPage
	'作  用：获取网页源码
	'参  数：HttpUrl ------网页地址
	'==================================================
	Function GetHttpPage(HttpUrl)
	   If IsNull(HttpUrl)=True Or Len(HttpUrl)<18 Or HttpUrl="$False$" Then
	      GetHttpPage="$False$"
	      Exit Function
	   End If
	   Dim Http
	   Set Http=server.createobject("MSXML2.XMLHTTP")
	   Http.open "GET",HttpUrl,False
	   Http.Send()
	   If Http.Readystate<>4 then
	      Set Http=Nothing 
	      GetHttpPage="$False$"
	      Exit function
	   End if
	   GetHTTPPage=bytesToBSTR(Http.responseBody,"GB2312")
	   Set Http=Nothing
	   If Err.number<>0 then
	      Err.Clear
	   End If
	End Function

	'==================================================
	'函数名：BytesToBstr
	'作  用：将获取的源码转换为中文
	'参  数：Body ------要转换的变量
	'参  数：Cset ------要转换的类型
	'==================================================
	Function BytesToBstr(Body,Cset)
	   Dim Objstream
	   Set Objstream = Server.CreateObject("adodb.stream")
	   objstream.Type = 1
	   objstream.Mode =3
	   objstream.Open
	   objstream.Write body
	   objstream.Position = 0
	   objstream.Type = 2
	   objstream.Charset = Cset
	   BytesToBstr = objstream.ReadText 
	   objstream.Close
	   set objstream = nothing
	End Function


		
	Function GetKey(HTML,Start,Last) 
		filearray=split(HTML,Start) 
		filearray2=split(filearray(1),Last) 
		GetKey=filearray2(0) 
	End Function 	


	Function CorrectPattern(ByVal str)
		str = Replace(str, "\", "\\")
		str = Replace(str, "~", "\~")
		str = Replace(str, "!", "\!")
		str = Replace(str, "@", "\@")
		str = Replace(str, "#", "\#")
		str = Replace(str, "%", "\%")
		str = Replace(str, "^", "\^")
		str = Replace(str, "&", "\&")
		str = Replace(str, "*", "\*")
		str = Replace(str, "(", "\(")
		str = Replace(str, ")", "\)")
		str = Replace(str, "-", "\-")
		str = Replace(str, "+", "\+")
		str = Replace(str, "[", "\[")
		str = Replace(str, "]", "\]")
		str = Replace(str, "<", "\<")
		str = Replace(str, ">", "\>")
		str = Replace(str, ".", "\.")
		str = Replace(str, "/", "\/")
		str = Replace(str, "?", "\?")
		str = Replace(str, "=", "\=")
		str = Replace(str, "|", "\|")
		str = Replace(str, "$", "\$")
		CorrectPattern = str
	End Function
	
	'================================================
	'函数名：ReplaceTrim
	'作  用：过滤掉字符中所有的tab和回车和换行
	'================================================
	Function ReplacedTrim(ByVal strContent)
		On Error Resume Next
		Dim re
		Set re = New RegExp
		re.IgnoreCase = True
		re.Global = True
		re.Pattern = "(" & Chr(8) & "|" & Chr(9) & "|" & Chr(10) & "|" & Chr(13) & ")"
		strContent = re.Replace(strContent, vbNullString)
		re.Pattern = "(<!--(.+?)-->)"
		strContent = re.Replace(strContent, vbNullString)
		Set re = Nothing
		ReplacedTrim = strContent
		Exit Function
	End Function
		
	'==================================================
	'函数名：GetBody
	'作  用：截取字符串
	'参  数：ConStr ------将要截取的字符串
	'参  数：StartStr ------开始字符串
	'参  数：OverStr ------结束字符串
	'参  数：IncluL ------是否包含StartStr
	'参  数：IncluR ------是否包含OverStr
	'==================================================
	Function GetBody(ConStr,StartStr,OverStr,IncluL,IncluR)
	   If ConStr="$False$" or ConStr="" or IsNull(ConStr)=True Or StartStr="" or IsNull(StartStr)=True Or OverStr="" or IsNull(OverStr)=True Then
	      GetBody="$False$"
	      Exit Function
	   End If
	   Dim ConStrTemp
	   Dim Start,Over
	   ConStrTemp=Lcase(ConStr)
	   StartStr=Lcase(StartStr)
	   OverStr=Lcase(OverStr)
	   Start = InStrB(1, ConStrTemp, StartStr, vbBinaryCompare)
	   If Start<=0 then
	      GetBody="$False$"
	      Exit Function
	   Else
	      If IncluL=False Then
	         Start=Start+LenB(StartStr)
	      End If
	   End If
	   Over=InStrB(Start,ConStrTemp,OverStr,vbBinaryCompare)
	   If Over<=0 Or Over<=Start then
	      GetBody="$False$"
	      Exit Function
	   Else
	      If IncluR=True Then
	         Over=Over+LenB(OverStr)
	      End If
	   End If
	   GetBody=MidB(ConStr,Start,Over-Start)
	End Function
		
	'==================================================
	'函数名：GetArray
	'作  用：提取链接地址，以$Array$分隔
	'参  数：ConStr ------提取地址的原字符
	'参  数：StartStr ------开始字符串
	'参  数：OverStr ------结束字符串
	'参  数：IncluL ------是否包含StartStr
	'参  数：IncluR ------是否包含OverStr
	'==================================================
	Function GetArray(Byval ConStr,StartStr,OverStr,IncluL,IncluR)
	   If ConStr="$False$" or ConStr="" Or IsNull(ConStr)=True or StartStr="" Or OverStr="" or  IsNull(StartStr)=True Or IsNull(OverStr)=True Then
	      GetArray="$False$"
	      Exit Function
	   End If
	   Dim TempStr,TempStr2,objRegExp,Matches,Match
	   TempStr=""
	   Set objRegExp = New Regexp 
	   objRegExp.IgnoreCase = True 
	   objRegExp.Global = True
	   objRegExp.Pattern = "("&StartStr&").+?("&OverStr&")"
	   Set Matches =objRegExp.Execute(ConStr) 
	   For Each Match in Matches
	      TempStr=TempStr & "$Array$" & Match.Value
	   Next 
	   Set Matches=nothing
	
	   If TempStr="" Then
	      GetArray="$False$"
	      Exit Function
	   End If
	   TempStr=Right(TempStr,Len(TempStr)-7)
	   If IncluL=False then
	      objRegExp.Pattern =StartStr
	      TempStr=objRegExp.Replace(TempStr,"")
	   End if
	   If IncluR=False then
	      objRegExp.Pattern =OverStr
	      TempStr=objRegExp.Replace(TempStr,"")
	   End if
	   Set objRegExp=nothing
	   Set Matches=nothing
	   
	   TempStr=Replace(TempStr,"""","")
	   TempStr=Replace(TempStr,"'","")
	   TempStr=Replace(TempStr," ","")
	   TempStr=Replace(TempStr,"(","")
	   TempStr=Replace(TempStr,")","")
	
	   If TempStr="" then
	      GetArray="$False$"
	   Else
	      GetArray=TempStr
	   End if
	End Function

'**************************************************
'过程名：WriteErrMsg
'作  用：显示错误提示信息
'参  数：无
'**************************************************
sub WriteErrMsg(ErrMsg)
	dim strErr
	strErr=strErr & "<html><head><title>错误信息</title><meta http-equiv='Content-Type' content='text/html; charset=gb2312'>" & vbcrlf
	strErr=strErr & "<link href='css/style.css' rel='stylesheet' type='text/css'></head><body><br><br>" & vbcrlf
	strErr=strErr & "<table cellpadding=2 cellspacing=1 border=0 width='97%' class='tableBorder' align=center>" & vbcrlf
	strErr=strErr & "  <tr align='center' class='title'><td height='22'><strong>错误信息</strong></td></tr>" & vbcrlf
	strErr=strErr & "  <tr><td height='100' valign='top'><b>产生错误的可能原因：</b>" & ErrMsg &"</td></tr>" & vbcrlf
	strErr=strErr & "  <tr align='center'><td><a href='javascript:history.go(-1)'>&lt;&lt; 返回上一页</a></td></tr>" & vbcrlf
	strErr=strErr & "</table>" & vbcrlf
	strErr=strErr & "</body></html>" & vbcrlf
	response.write strErr
end sub

'**************************************************
'过程名：WriteSucced
'作  用：显示成功提示信息
'参  数：无
'**************************************************
sub WriteSucced(SuccessMsg)
	dim strErr
	strErr=strErr & "<html><head><title>成功信息</title><meta http-equiv='Content-Type' content='text/html; charset=gb2312'>" & vbcrlf
	strErr=strErr & "<link href='css/style.css' rel='stylesheet' type='text/css'></head><body><br><br>" & vbcrlf
	strErr=strErr & "<table cellpadding=2 cellspacing=1 border=0 width='97%' class='tableBorder' align=center>" & vbcrlf
	strErr=strErr & "  <tr align='center' class='title'><td height='22'><strong>恭喜你！</strong></td></tr>" & vbcrlf
	strErr=strErr & "  <tr><td height='100' valign='top' align='center'>" & SuccessMsg &"</td></tr>" & vbcrlf
	strErr=strErr & "</table>" & vbcrlf
	strErr=strErr & "</body></html>" & vbcrlf
	response.write strErr
end sub

Function CheckHTML(ByVal str)
		On Error Resume Next
		
		Dim re
		Set re = New RegExp
		re.IgnoreCase = True
		re.Global = True
		re.Pattern = "<(.[^>]*)>"
		str = re.Replace(str, "")
		Set re = Nothing
		CheckHTML = str
		Exit Function
End function

'==================================================
'过程名：ShowChannel_Name
'作  用：显示频道名称
'参  数：ChannelID ------频道ID
'==================================================
Sub ShowChannel_Name(ChannelID)   
   Dim Sqlc,Rsc,TempStr
   ChannelID=Clng(ChannelID)
   Sqlc ="select top 1 ChannelName from Channel Where ChannelID=" & ChannelID   
   Set Rsc=server.CreateObject("adodb.recordset")   
   Rsc.open Sqlc,Conn,1,1