所属类别：ASP编程

特别推荐：免费发布信息 承包关键词~~抢爆了！^HOT!

<%'===============================================================' Function For PJblog2' 更新时间: 2006-6-2'==============================================================='*************************************'防止外部提交'*************************************function ChkPost() dim server_v1,server_v2 chkpost=false server_v1=Cstr(Request.ServerVariables("HTTP_REFERER")) server_v2=Cstr(Request.ServerVariables("SERVER_NAME")) If Mid(server_v1,8,Len(server_v2))<>server_v2 then chkpost=False else chkpost=True end If end function'*************************************'IP过滤'*************************************function MatchIP(IP) on error resume next MatchIP=false Dim SIp,SplitIP for each SIp in FilterIP SIp=replace(SIp,"*","\d*") SplitIP=split(SIp,".") Dim re, strMatchs,strIP Set re=new RegExp re.IgnoreCase =True re.Global=True re.Pattern="("&SplitIP(0)&")."&"("&SplitIP(1)&")."&"("&SplitIP(2)&")."&"("&SplitIP(3)&")" Set strMatchs=re.Execute(IP) strIP=strMatchs(0).SubMatches(0) & "." & strMatchs(0).SubMatches(1)& "." & strMatchs(0).SubMatches(2)& "." & strMatchs(0).SubMatches(3) if strIP=IP then MatchIP=true:exit function Set strMatchs=Nothing Set re=Nothing nextend function'*************************************'获得注册码'*************************************Function getcode() getcode= ""End Function'*************************************'限制上传文件类型'*************************************Function IsvalidFile(File_Type) IsvalidFile = False Dim GName For Each GName in UP_FileType If File_Type = GName Then IsvalidFile = True Exit For End If NextEnd Function'*************************************'限制插件名称'*************************************Function IsvalidPlugins(Plugins_Name) dim NoAllowNames,NoAllowName NoAllowNames="user,bloginfo,calendar,comment,search,links,archive,category,contentlist" NoAllowName=split(NoAllowNames,",") IsvalidPlugins = true Dim GName Plugins_Name=trim(lcase(Plugins_Name)) For Each GName in NoAllowName If Plugins_Name = GName Then IsvalidPlugins = false Exit For End If NextEnd Function'*************************************'检测是否只包含英文和数字'*************************************Function IsValidChars(str) Dim re,chkstr Set re=new RegExp re.IgnoreCase =true re.Global=True re.Pattern="[^_\.a-zA-Z\d]" IsValidChars=True chkstr=re.Replace(str,"") if chkstr<>str then IsValidChars=False set re=nothingEnd Function'*************************************'检测是否只包含英文和数字'*************************************Function IsvalidValue(ArrayN,Str) IsvalidValue = false Dim GName For Each GName in ArrayN If Str = GName Then IsvalidValue = true Exit For End If NextEnd Function'*************************************'检测是否有效的数字'*************************************Function IsInteger(Para) IsInteger=False If Not (IsNull(Para) Or Trim(Para)="" Or Not IsNumeric(Para)) Then IsInteger=True End IfEnd Function'*************************************'用户名检测'*************************************Function IsValidUserName(byVal UserName) on error resume next 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 NextEnd Function'*************************************'检测是否有效的E-mail地址'*************************************Function IsValidEmail(Email) 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 IfEnd Function'*************************************'加亮关键字'*************************************Function highlight(byVal strContent,byRef arrayWords) Dim intCounter,strTemp,intPos,intTagLength,intKeyWordLength,bUpdate if len(arrayWords)<1 then highlight=strContent:exit function For intPos = 1 to Len(strContent) bUpdate = False If Mid(strContent, intPos, 1) = "<" Then On Error Resume Next intTagLength = (InStr(intPos, strContent, ">", 1) - intPos) if err then highlight=strContent err.clear end if strTemp = strTemp & Mid(strContent, intPos, intTagLength) intPos = intPos + intTagLength End If If arrayWords <> "" Then intKeyWordLength = Len(arrayWords) If LCase(Mid(strContent, intPos, intKeyWordLength)) = LCase(arrayWords) Then strTemp = strTemp & "" & Mid(strContent, intPos, intKeyWordLength) & "" intPos = intPos + intKeyWordLength - 1 bUpdate = True End If End If If bUpdate = False Then strTemp = strTemp & Mid(strContent, intPos, 1) End If Next highlight = strTempEnd 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,"$1cript ") re.Pattern="(s)(cript)" Str = re.replace(Str,"$1cript") re.Pattern="(o)(bject)" Str = re.replace(Str,"$1bject") re.Pattern="(a)(pplet)" Str = re.replace(Str,"$1pplet") re.Pattern="(e)(mbed)" Str = re.replace(Str,"$1mbed") Set re=Nothing Str = Replace(Str, ">", ">") Str = Replace(Str, "<", "<") checkURL=Strend function'*************************************'过滤文件名字'*************************************Function FixName(UpFileExt) If IsEmpty(UpFileExt) Then Exit Function FixName = Ucase(UpFileExt) FixName = Replace(FixName,Chr(0),"") FixName = Replace(FixName,".","") FixName = Replace(FixName,"ASP","") FixName = Replace(FixName,"ASA","") FixName = Replace(FixName,"ASPX","") FixName = Replace(FixName,"CER","") FixName = Replace(FixName,"CDX","") FixName = Replace(FixName,"HTR","")End Function'*************************************'过滤特殊字符'*************************************Function CheckStr(byVal ChkStr) Dim Str:Str=ChkStr If IsNull(Str) Then CheckStr = "" Exit Function End If Str = Replace(Str, "&", "&") Str = Replace(Str,"'","'") Str = Replace(Str,"""",""") Dim re Set re=new RegExp re.IgnoreCase =True re.Global=True re.Pattern="(w)(here)" Str = re.replace(Str,"$1here") re.Pattern="(s)(elect)" Str = re.replace(Str,"$1elect") re.Pattern="(i)(nsert)" Str = re.replace(Str,"$1nsert") re.Pattern="(c)(reate)" Str = re.replace(Str,"$1reate") re.Pattern="(d)(rop)" Str = re.replace(Str,"$1rop") re.Pattern="(a)(lter)" Str = re.replace(Str,"$1lter") re.Pattern="(d)(elete)" Str = re.replace(Str,"$1elete") re.Pattern="(u)(pdate)" Str = re.replace(Str,"$1pdate") re.Pattern="(\s)(or)" Str = re.replace(Str,"$1or") Set re=Nothing CheckStr=StrEnd Function'*************************************'恢复特殊字符'*************************************Function UnCheckStr(ByVal Str) If IsNull(Str) Then UnCheckStr = "" Exit Function End If Str = Replace(Str,"'","'") Str = Replace(Str,""","""") Dim re Set re=new RegExp re.IgnoreCase =True re.Global=True re.Pattern="(w)(here)" str = re.replace(str,"$1here") re.Pattern="(s)(elect)" str = re.replace(str,"$1elect") re.Pattern="(i)(nsert)" str = re.replace(str,"$1nsert") re.Pattern="(c)(reate)" str = re.replace(str,"$1reate") re.Pattern="(d)(rop)" str = re.replace(str,"$1rop") re.Pattern="(a)(lter)" str = re.replace(str,"$1lter") re.Pattern="(d)(elete)" str = re.replace(str,"$1elete") re.Pattern="(u)(pdate)" str = re.replace(str,"$1pdate") re.Pattern="(\s)(or)" Str = re.replace(Str,"$1or") Set re=Nothing Str = Replace(Str, "&", "&") UnCheckStr=StrEnd Function'*************************************'转换HTML代码'*************************************Function HTMLEncode(ByVal reString) Dim Str:Str=reString If Not IsNull(Str) Then Str = Replace(Str, ">", ">") Str = Replace(Str, "<", "<") Str = Replace(Str, CHR(9), "") Str = Replace(Str, CHR(39), "'") Str = Replace(Str, CHR(32)&CHR(32), " ") Str = Replace(Str, CHR(34), """) Str = Replace(Str, CHR(13), "") Str = Replace(Str, CHR(10), "") HTMLEncode = Str End IfEnd Function'*************************************'转换最新评论和日志HTML代码'*************************************Function CCEncode(ByVal reString) Dim Str:Str=reString If Not IsNull(Str) Then Str = Replace(Str, ">", ">") Str = Replace(Str, "<", "<") Str = Replace(Str, CHR(9), "") Str = Replace(Str, CHR(39), "'") Str = Replace(Str, CHR(32)&CHR(32), " ") Str = Replace(Str, CHR(34), """) Str = Replace(Str, CHR(13), "") Str = Replace(Str, CHR(10), " ") CCEncode = Str End IfEnd Function'*************************************'反转换HTML代码'*************************************Function HTMLDecode(ByVal reString) Dim Str:Str=reString If Not IsNull(Str) Then Str = Replace(Str, ">", ">") Str = Replace(Str, "<", "<") Str = Replace(Str, "", CHR(9)) Str = Replace(Str, "'", CHR(39)) Str = Replace(Str, " ",CHR(32)&CHR(32)) Str = Replace(Str, """, CHR(34)) Str = Replace(Str, "", CHR(13)) Str = Replace(Str, "", CHR(10)) HTMLDecode = Str End IfEnd Function'*************************************'恢复&字符'*************************************function ClearHTML(ByVal reString) Dim Str:Str=reString If Not IsNull(Str) Then Str = Replace(Str, "&", "&") ClearHTML = Str End IfEnd Function'*************************************'过滤textarea'*************************************Function UBBFilter(ByVal reString) Dim Str:Str=reString If Not IsNull(Str) Then Str = Replace(Str, "", "") UBBFilter = Str End IfEnd Function'*************************************'过滤HTML代码'*************************************Function EditDeHTML(byVal Content) EditDeHTML=Content IF Not IsNull(EditDeHTML) Then EditDeHTML=UnCheckStr(EditDeHTML) EditDeHTML=Replace(EditDeHTML,"&","&") EditDeHTML=Replace(EditDeHTML,"<","<") EditDeHTML=Replace(EditDeHTML,">",">") EditDeHTML=Replace(EditDeHTML,chr(34),""") EditDeHTML=Replace(EditDeHTML,chr(39),"'") End IFEnd Function'*************************************'日期转换函数'*************************************Function DateToStr(DateTime,ShowType) Dim DateMonth,DateDay,DateHour,DateMinute,DateWeek,DateSecond Dim FullWeekday,shortWeekday,Fullmonth,Shortmonth,TimeZone1,TimeZone2 TimeZone1="+0800" TimeZone2="+08:00" FullWeekday=Array("Sunday","Monday","Tuesday","Wednesday","Thursday","Friday","Saturday") shortWeekday=Array("Sun","Mon","Tue","Wed","Thu","Fri","Sat") Fullmonth=Array("January","February","March","April","May","June","July","August","September","October","November","December") Shortmonth=Array("Jan","Feb","Mar","Apr","May","Jun","Jul","Aug","Sep","Oct","Nov","Dec") DateMonth=Month(DateTime) DateDay=Day(DateTime) DateHour=Hour(DateTime) DateMinute=Minute(DateTime) DateWeek=weekday(DateTime) DateSecond=Second(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" 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 "mdy" Dim DayEnd select Case DateDay Case 1 DayEnd="st" Case 2 DayEnd="nd" Case 3 DayEnd="rd" Case Else DayEnd="th" End Select DateToStr=Fullmonth(DateMonth-1)&" "&DateDay&DayEnd&" "&Right(Year(DateTime),4) Case "w,d m y H:I:S" DateSecond=Second(DateTime) If Len(DateHour)<2 Then DateHour="0"&DateHour If Len(DateSecond)<2 Then DateSecond="0"&DateSecond DateToStr=shortWeekday(DateWeek-1)&","&DateDay&" "& Left(Fullmonth(DateMonth-1),3) &" "&Right(Year(DateTime),4)&" "&DateHour&":"&DateMinute&":"&DateSecond&" "&TimeZone1 Case "y-m-dTH:I:S" If Len(DateHour)<2 Then DateHour="0"&DateHour If Len(DateSecond)<2 Then DateSecond="0"&DateSecond DateToStr=Year(DateTime)&"-"&DateMonth&"-"&DateDay&"T"&DateHour&":"&DateMinute&":"&DateSecond&TimeZone2 Case Else If Len(DateHour)<2 Then DateHour="0"&DateHour DateToStr=Year(DateTime)&"-"&DateMonth&"-"&DateDay&" "&DateHour&":"&DateMinute End SelectEnd Function'*************************************'分页函数'*************************************dim FirstShortCut,ShortCutFirstShortCut=falseFunction MultiPage(Numbers,Perpage,Curpage,Url_Add,aname,Style) CurPage=Int(Curpage) Numbers=Int(Numbers) Dim URL URL=Request.ServerVariables("Script_Name")&Url_Add MultiPage="" Dim Page,Offset,PageI' If Int(Numbers)>Int(PerPage) Then Page=9 Offset=4 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)Pages Then FromPage =Curpage-Pages +ToPage ToPage=Pages If (ToPage-FromPage)" 'if Curpage<>1 then MultiPage=MultiPage&"" MultiPage=MultiPage&"" if Curpage<>1 then MultiPage=MultiPage&"< " if not FirstShortCut then ShortCut=" accesskey="",""" else ShortCut="" if Curpage<>1 then MultiPage=MultiPage&"" For PageI=FromPage TO ToPage If PageI<>CurPage Then MultiPage=MultiPage&""&PageI&" " Else MultiPage=MultiPage&""&PageI&"" if PageI<>Pages then MultiPage=MultiPage&" " End If Next if not FirstShortCut then ShortCut=" accesskey="".""" else ShortCut="" if Curpage<>pages then MultiPage=MultiPage&"" if Curpage<>pages then MultiPage=MultiPage&">" MultiPage=MultiPage&"" 'If Int(Pages)>Int(Page) Then ' MultiPage=MultiPage&"..."&pages&"" 'End If 'if Curpage<>pages then MultiPage=MultiPage&"" MultiPage=MultiPage&""' End IfFirstShortCut=trueEnd Function'*************************************'切割内容 - 按行分割'*************************************Function SplitLines(byVal Content,byVal ContentNums) Dim ts,i,l ContentNums=int(ContentNums) If IsNull(Content) Then Exit Function i=1 ts = 0 For i=1 to Len(Content) l=Lcase(Mid(Content,i,5)) If l="" Then ts=ts+1 End If l=Lcase(Mid(Content,i,4)) If l="" Then ts=ts+1 End If l=Lcase(Mid(Content,i,3)) If l="" Then ts=ts+1 End If If ts>ContentNums Then Exit For Next If ts>ContentNums Then Content=Left(Content,i-1) End If SplitLines=ContentEnd Function当前1/2页12下一页

....