function.asp

割自ro-blog v2.0

<%
Function Strurls(str,notes)
Strurls=ubound(split(LCase(str),notes))
End Function
Sub MemberCenter '用户中心
	IF memName=Empty Then
		Response.Write("<table width=""100%"" border=""0"" align=""center"" cellpadding=""0"" cellspacing=""4"" ><form name=""memlogin"" method=""post"" action=""logging.asp?action=login""><tr><td align=""left"">用户：<input name=""username"" type=""text"" id=""username"" value="""" size=""12"" maxlength=""20"">密码：<input name=""Password"" type=""password"" id=""Password"" value="""" size=""12"" maxlength=""20""><input name=""Login"" type=""submit"" id=""Login"" value="" 登 陆 ""></td></form></tr></table>")
	Else
      Response.Write("<table width=""100%"" border=""0"" align=""center"" cellpadding=""0"" cellspacing=""4"" ><tr><td  colspan=""2"" valign=""top"">HELLO:&nbsp;<font color=""red"">"&memName&"</font>&nbsp;")
	  IF memStatus=1 Then
		Response.Write("<a href=""admin.asp"" target=""_blank""><img src=""images/icon_admincp.gif""/ align=""absmiddle"" border=""0""> 系统管理&nbsp;</a>")
	  End IF
	  Response.Write("<a href=""member.asp?action=edit""><img src=""images/icon_memedit.gif""/ align=""absmiddle"" border=""0""> 修改资料</a>&nbsp;<a href=""logging.asp?action=logout""><img src=""images/icon_logout.gif""/ align=""absmiddle"" border=""0""> 退出登录</a></td></tr></table>")
	End IF
End Sub
Function checkURL(str)
	If IsEmpty(str) Then Exit Function
	Str = Lcase(str)
	Str = Replace(Str, "document.cookie", "document&#46;cookie")
	Str = Replace(Str, "document.write", "document&#46;write")
	Str = Replace(Str, "javascript:", "javascript ")
	Str = Replace(Str, "jscript:", "jscript ")
	Str = Replace(Str, "vbscript:", "vbscript ")
	Str = Replace(Str, "script", "&#115;cript")
	checkURL=Str    
end function

Function CheckBadWords(byVal theString) '脏字过滤
	Dim WordFilterEntry,WordFilterArray,re,theMatches,tmpString,i
	Set re=new RegExp
	re.IgnoreCase =true
	re.Global=True
	For Each WordFilterEntry IN Arr_WordFilter
		WordFilterArray=Split(WordFilterEntry,"|")
		'Inject Regular Expression Pattern
		tmpString=""
		For i=1 To Len(WordFilterArray(2))-1
			tmpString=tmpString&Mid(WordFilterArray(2),i,1)&"(["&Mid(WordFilterArray(2),i,1)&"_\s\W]{0,3})"
		Next
		tmpString=tmpString&Right(WordFilterArray(2),1)
		re.Pattern=tmpString
		set theMatches=re.Execute(theString)
		If theMatches.Count>0 Then
			If WordFilterArray(1)="0" Then
				theString=re.Replace(theString,WordFilterArray(3))
			Else
				CheckBadWords=""
				Exit Function
			End If
		End If
	Next
	set theMatches=nothing
	set re=nothing
	CheckBadWords=theString
End Function

Function IsInteger(Para) '检测是否有效的数字
	IsInteger=False
	If Not (IsNull(Para) Or Trim(Para)="" Or Not IsNumeric(Para)) Then
		IsInteger=True
	End If
End Function

Function RemoveSpecialChars(str)
	Dim re
	Set re=new RegExp
	re.IgnoreCase =true
	re.Global=True
	re.Pattern="[^_\.a-zA-Z\d]"
	RemoveSpecialChars=re.Replace(str,"")
	set re=nothing
End Function

Function CheckStr(byVal ChkStr) '检查无效字符
	Dim Str:Str=ChkStr
	Str=Trim(Str)
	If IsNull(Str) Then
		CheckStr = ""
		Exit Function 
	End If
	Dim re
	Set re=new RegExp
	re.IgnoreCase =True
	re.Global=True
	re.Pattern="(\r\n){3,}"
	Str=re.Replace(Str,"$1$1$1")
	Set re=Nothing
	Str = Replace(Str,"'","''")
	Str = Replace(Str, "select", "sel&#101;ct")
	Str = Replace(Str, "join", "jo&#105;n")
	Str = Replace(Str, "union", "un&#105;on")
	Str = Replace(Str, "where", "wh&#101;re")
	Str = Replace(Str, "insert", "ins&#101;rt")
	Str = Replace(Str, "delete", "del&#101;te")
	Str = Replace(Str, "update", "up&#100;ate")
	Str = Replace(Str, "like", "lik&#101;")
	Str = Replace(Str, "drop", "dro&#112;")
	Str = Replace(Str, "create", "cr&#101;ate")
	Str = Replace(Str, "modify", "mod&#105;fy")
	Str = Replace(Str, "rename", "ren&#097;me")
	Str = Replace(Str, "alter", "alt&#101;r")
	Str = Replace(Str, "cast", "ca&#115;t")
	Str = Replace(Str, "and", "an&#100;")
	Str = Replace(Str, " or", " o&#114;")
	Str = Replace(Str, "パ", "&pa;")
    Str = Replace(Str, "ポ", "&po;")
    Str = Replace(Str, "ゾ", "&zo;")
    Str = Replace(Str, "ギ", "&gi;")
    Str = Replace(Str, "ビ", "&bi;")
    Str = Replace(Str, "ヴ", "&wu;")
Str = Replace(Str, "ダ", "&da;")
Str = Replace(Str, "グ", "&ku;")
Str = Replace(Str, "ピ", "&pi;")
Str = Replace(Str, "ヂ", "&ji;")
Str = Replace(Str, "ゲ", "&ke;")
Str = Replace(Str, "ブ", "&bu;")
Str = Replace(Str, "ヅ", "&zu;")
Str = Replace(Str, "ゴ", "&ko;")
Str = Replace(Str, "プ", "&pu;")
Str = Replace(Str, "デ", "&de;")
Str = Replace(Str, "ザ", "&za;")
Str = Replace(Str, "ベ", "&be;")
Str = Replace(Str, "ド", "&do;")
Str = Replace(Str, "ジ", "&zi;")
Str = Replace(Str, "ペ", "&pe;")
Str = Replace(Str, "バ", "&ba;")
Str = Replace(Str, "ズ", "&zi;")
Str = Replace(Str, "ボ", "&bo;")
	CheckStr=Str
End Function

Function UnCheckStr(Str)
		Str = Replace(Str, "sel&#101;ct", "select")
		Str = Replace(Str, "jo&#105;n", "join")
		Str = Replace(Str, "un&#105;on", "union")
		Str = Replace(Str, "wh&#101;re", "where")
		Str = Replace(Str, "ins&#101;rt", "insert")
		Str = Replace(Str, "del&#101;te", "delete")
		Str = Replace(Str, "up&#100;ate", "update")
		Str = Replace(Str, "lik&#101;", "like")
		Str = Replace(Str, "dro&#112;", "drop")
		Str = Replace(Str, "cr&#101;ate", "create")
		Str = Replace(Str, "mod&#105;fy", "modify")
		Str = Replace(Str, "ren&#097;me", "rename")
		Str = Replace(Str, "alt&#101;r", "alter")
		Str = Replace(Str, "ca&#115;t", "cast")
		Str = Replace(Str, "an&#100;", "and")
	    Str = Replace(Str, "o&#114;", " or")
		Str = Replace(Str, "&pa;", "パ")
                Str = Replace(Str, "&po;", "ポ")
                Str = Replace(Str, "&zo;", "ゾ")
                Str = Replace(Str, "&gi;", "ギ")
                Str = Replace(Str, "&bi;", "ビ")
                Str = Replace(Str, "&wu;", "ヴ")
Str = Replace(Str, "&da;", "ダ")
Str = Replace(Str, "&ku;", "グ")
Str = Replace(Str, "&pi;", "ピ")
Str = Replace(Str, "&ji;", "ヂ")
Str = Replace(Str, "&ke;", "ゲ")
Str = Replace(Str, "&bu;", "ブ")
Str = Replace(Str, "&zu;", "ヅ")
Str = Replace(Str, "&ko;", "ゴ")
Str = Replace(Str, "&pu;", "プ")
Str = Replace(Str, "&de;", "デ")
Str = Replace(Str, "&za;", "ザ")
Str = Replace(Str, "&be;", "ベ")
Str = Replace(Str, "&do;", "ド")
Str = Replace(Str, "&zi;", "ジ")
Str = Replace(Str, "&pe;", "ペ")
Str = Replace(Str, "&ba;", "バ")
Str = Replace(Str, "&zi;", "ズ")
Str = Replace(Str, "&bo;", "ボ")
		UnCheckStr=Str
End Function

Function HTMLEncode(reString) '转换HTML代码
	Dim Str:Str=reString
	If Not IsNull(Str) Then
		Str = UnCheckStr(Str)
		Str = Replace(Str, "&", "&amp;")
		Str = Replace(Str, ">", "&gt;")
		Str = Replace(Str, "<", "&lt;")
		Str = Replace(Str, CHR(32), "&nbsp;")
	    Str = Replace(Str, CHR(9), "&nbsp;")
		Str = Replace(Str, CHR(9), "&#160;&#160;&#160;&#160;")
		Str = Replace(Str, CHR(34), "&quot;")
		Str = Replace(Str, CHR(39), "&#39;")
		Str = Replace(Str, CHR(13), "")
		Str = Replace(Str, CHR(10), "<br>")
		HTMLEncode = Str
	End If
End Function

Function HTMLDecode(reString) '转换HTML代码
	Dim Str:Str=reString
	If Not IsNull(Str) Then
		Str = Replace(Str, "&amp;", "&")
		Str = Replace(Str, "&gt;", ">")
		Str = Replace(Str, "&lt;", "<")
		Str = Replace(Str, "&nbsp;", CHR(32))
	    Str = Replace(Str, "&nbsp;", CHR(9))
		Str = Replace(Str, "&#160;&#160;&#160;&#160;", CHR(9))
		Str = Replace(Str, "&quot;", CHR(34))
		Str = Replace(Str, "&#39;", CHR(39))
		Str = Replace(Str, "", CHR(13))
		Str = Replace(Str, "<br>", CHR(10))
		HTMLDecode = Str
	End If
End Function

Function EditDeHTML(byVal Content)
	EditDeHTML=Content
	IF Not IsNull(EditDeHTML) Then
		EditDeHTML=UnCheckStr(EditDeHTML)
		EditDeHTML=Replace(EditDeHTML,"&","&amp;")
		EditDeHTML=Replace(EditDeHTML,"<","&lt;")
		EditDeHTML=Replace(EditDeHTML,">","&gt;")
		EditDeHTML=Replace(EditDeHTML,chr(34),"&quot;")
		EditDeHTML=Replace(EditDeHTML,chr(39),"&#39;")
	End IF
End Function

Function DateToStr(DateTime,ShowType)  '日期转换函数
	Dim DateMonth,DateDay,DateHour,DateMinute
	DateMonth=Month(DateTime)
	DateDay=Day(DateTime)
	DateHour=Hour(DateTime)
	DateMinute=Minute(DateTime)
	If Len(DateMonth)<2 Then DateMonth="0"&DateMonth
	If Len(DateDay)<2 Then DateDay="0"&DateDay
	If Len(DateMinute)<2 Then DateMinute="0"&DateMinute
	Select Case ShowType
	Case "Y-m-d"  
		DateToStr=Year(DateTime)&"-"&DateMonth&"-"&DateDay
	Case "Y-m-d H:I A"
		Dim DateAMPM
		If DateHour>12 Then 
			DateHour=DateHour-12
			DateAMPM="PM"
		Else
			DateHour=DateHour
			DateAMPM="AM"
		End If
		If Len(DateHour)<2 Then DateHour="0"&DateHour	
		DateToStr=Year(DateTime)&"-"&DateMonth&"-"&DateDay&" "&DateHour&":"&DateMinute&" "&DateAMPM
	Case "Y-m-d H:I:S"
		Dim DateSecond
		DateSecond=Second(DateTime)
		If Len(DateHour)<2 Then DateHour="0"&DateHour	
		If Len(DateSecond)<2 Then DateSecond="0"&DateSecond
		DateToStr=Year(DateTime)&"-"&DateMonth&"-"&DateDay&" "&DateHour&":"&DateMinute&":"&DateSecond
	Case "YmdHIS"
		DateSecond=Second(DateTime)
		If Len(DateHour)<2 Then DateHour="0"&DateHour	
		If Len(DateSecond)<2 Then DateSecond="0"&DateSecond
		DateToStr=Year(DateTime)&DateMonth&DateDay&DateHour&DateMinute&DateSecond	
	Case "ym"
		DateToStr=Right(Year(DateTime),2)&DateMonth
	Case "d"
		DateToStr=DateDay
    Case "ymd"
        DateToStr=Right(Year(DateTime),4)&DateMonth&DateDay
	Case Else
		If Len(DateHour)<2 Then DateHour="0"&DateHour
		DateToStr=Year(DateTime)&"-"&DateMonth&"-"&DateDay&" "&DateHour&":"&DateMinute
	End Select
End Function

Function IsValidUserName(byVal UserName)'用户名检测
	Dim i,c
	Dim VUserName
	IsValidUserName = True
	For i = 1 To Len(UserName)
		c = Lcase(Mid(UserName, i, 1))
		If InStr("$!<>?#^%@~`&*();:+='"" 	", c) > 0 Then
				IsValidUserName = False
				Exit Function
		End IF
	Next
	For Each VUserName in Register_UserName
		If UserName = VUserName Then
			IsValidUserName = False
			Exit For
		End If
	Next
End Function

Function IsValidEmail(Email) '检测是否有效的E-mail地址
	Dim names, name, i, c
	IsValidEmail = True
	Names = Split(email, "@")
	If UBound(names) <> 1 Then
   		IsValidEmail = False
   		Exit Function
	End If
	For Each name IN names
		If Len(name) <= 0 Then
     		IsValidEmail = False
     		Exit Function
   		End If
   		For i = 1 to Len(name)
     		c = Lcase(Mid(name, i, 1))
     		If InStr("abcdefghijklmnopqrstuvwxyz_-.", c) <= 0 And Not IsNumeric(c) Then
       			IsValidEmail = false
       			Exit Function
     		End If
   		Next
   		If Left(name, 1) = "." or Right(name, 1) = "." Then
      		IsValidEmail = false
      		Exit Function
   		End If
	Next
	If InStr(names(1), ".") <= 0 Then
   		IsValidEmail = False
   		Exit Function
	End If
	i = Len(names(1)) - InStrRev(names(1), ".")
	If i <> 2 And i <> 3 Then
   		IsValidEmail = False
   		Exit Function
	End If
	If InStr(email, "..") > 0 Then
   		IsValidEmail = False
	End If
End Function

Function MultiPage(Numbers,Perpage,Curpage,Url_Add,aname) '分页函数
	CurPage=Int(Curpage)
	Dim URL
	URL=Request.ServerVariables("Script_Name")&Url_Add
	MultiPage=""
	Dim Page,Offset,PageI
	If Int(Numbers)>Int(PerPage) Then
		Page=10
		Offset=5
		Dim Pages,FromPage,ToPage
		If Numbers Mod Cint(Perpage)=0 Then
			Pages=Int(Numbers/Perpage)
		Else
			Pages=Int(Numbers/Perpage)+1
		End If
		FromPage=Curpage-Offset
		ToPage=Curpage+Page-Offset-1
		If Page>Pages Then
			FromPage=1
			ToPage=Pages
		Else
			If FromPage<1 Then
				Topage=Curpage+1-FromPage
				FromPage=1
				If (ToPage-FromPage)<Page And (ToPage-FromPage)<Pages Then ToPage=Page
			ElseIF Topage>Pages Then
				FromPage =Curpage-Pages +ToPage
				ToPage=Pages
				If (ToPage-FromPage)<Page And (ToPage-FromPage)<Pages Then FromPage=Pages-Page+1
			End If
		End If
		MultiPage="<a href='"&Url&"page=1'><img src='images/arrow_left.gif' border=""0"" align=""center""></a> "
		For PageI=FromPage TO ToPage
			If PageI<>CurPage Then
				MultiPage=MultiPage&"<a href='"&Url&"page="&PageI&aname&"'>["&PageI&"]</a>&nbsp;"
			Else
				MultiPage=MultiPage&"<b>["&PageI&"]</b>&nbsp;"
			End If
		Next
		If Int(Pages)>Int(Page) Then
			MultiPage=MultiPage&" ... <a href='"&Url&"page="&Pages&aname&"'> "&pages&" <img src='images/arrow_right.gif' border=""0"" align=""center"" ></a>"
		Else
			MultiPage=MultiPage&"<a href='"&Url&"page="&Pages&aname&"'><img src='images/arrow_right.gif' border=""0"" align=""center"" ></a>"
		End If
	End If
End Function

Function Generator(Length)
	Dim i, tempS
	tempS = "abcdefghijklmnopqrstuvwxyz1234567890" 
	Generator = ""
	If isNumeric(Length) = False Then 
		Exit Function 
	End If 
	For i = 1 to Length 
		Randomize 
		Generator = Generator & Mid(tempS,Int((Len(tempS) * Rnd) + 1),1)
	Next 
End Function 

Function CutStr(byVal Str,byVal StrLen)
	Dim l,t,c,i
	l=Len(str)
	t=0
	For i=1 To l
		c=AscW(Mid(str,i,1))
		If c<0 Or c>255 Then t=t+2 Else t=t+1
		IF t>=StrLen Then
			CutStr=left(Str,i)&"..."
			Exit For
		Else
			CutStr=Str
		End If
	Next
End Function


Function DelQuote(strContent)
	If IsNull(strContent) Then Exit Function
	Dim re
	Set re=new RegExp
	re.IgnoreCase =True
	re.Global=True
	re.Pattern="(\[quote\])(.*?)(\[\/quote\])"
	strContent= re.Replace(strContent,"")
	Set re=Nothing
	DelQuote=strContent
End Function

Function getpychar(char) '得到拼音
	Dim tmp
	tmp=65536+Asc(char) 
	If(tmp>=45217 And tmp<=45252) Then 
	getpychar= "A" 
	ElseIF(tmp>=45253 And tmp<=45760) Then 
	getpychar= "B" 
	ElseIF(tmp>=45761 And tmp<=46317) Then 
	getpychar= "C" 
	ElseIF(tmp>=46318 And tmp<=46825) Then 
	getpychar= "D" 
	ElseIF(tmp>=46826 And tmp<=47009) Then 
	getpychar= "E" 
	ElseIF(tmp>=47010 And tmp<=47296) Then 
	getpychar= "F" 
	ElseIF(tmp>=47297 And tmp<=47613) Then 
	getpychar= "G" 
	ElseIF(tmp>=47614 And tmp<=48118) Then 
	getpychar= "H" 
	ElseIF(tmp>=48119 And tmp<=49061) Then 
	getpychar= "J" 
	ElseIF(tmp>=49062 And tmp<=49323) Then 
	getpychar= "K" 
	ElseIF(tmp>=49324 And tmp<=49895) Then 
	getpychar= "L" 
	ElseIF(tmp>=49896 And tmp<=50370) Then 
	getpychar= "M" 
	ElseIF(tmp>=50371 And tmp<=50613) Then 
	getpychar= "N" 
	ElseIF(tmp>=50614 And tmp<=50621) Then 
	getpychar= "O" 
	ElseIF(tmp>=50622 And tmp<=50905) Then 
	getpychar= "P" 
	ElseIF(tmp>=50906 And tmp<=51386) Then 
	getpychar= "Q" 
	ElseIF(tmp>=51387 And tmp<=51445) Then 
	getpychar= "R" 
	ElseIF(tmp>=51446 And tmp<=52217) Then 
	getpychar= "S" 
	ElseIF(tmp>=52218 And tmp<=52697) Then 
	getpychar= "T" 
	ElseIF(tmp>=52698 And tmp<=52979) Then 
	getpychar= "W" 
	ElseIF(tmp>=52980 And tmp<=53640) Then 
	getpychar= "X" 
	ElseIF(tmp>=53689 And tmp<=54480) Then 
	getpychar= "Y" 
	ElseIF(tmp>=54481 And tmp<=62289) Then 
	getpychar= "Z" 
	Else '如果不是中文，则不处理 
	getpychar=char 
	End If 
End Function
Function getpy(str)
	Dim i
	For i=1 To Len(str) 
	getpy=getpy&getpychar(Mid(str,i,1)) 
	Next 
End Function
%>