<%  '=============================================================== '  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  next  end function '************************************* '获得注册码 '*************************************   Function getcode()      getcode= "<img src=""common/getcode.asp"" alt="""" style=""margin-right:40px;""/>"         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     Next End 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     Next End 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=nothing End Function '************************************* '检测是否只包含英文和数字 '*************************************  Function IsvalidValue(ArrayN,Str)     IsvalidValue = false     Dim GName     For Each GName in ArrayN         If Str = GName Then              IsvalidValue = true             Exit For         End If     Next 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 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     Next End 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 If End 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 & "<span class=""high1"">" & Mid(strContent, intPos, intKeyWordLength) & "</span>"                     intPos = intPos + intKeyWordLength - 1                     bUpdate = True                 End If             End If         If bUpdate = False Then             strTemp = strTemp & Mid(strContent, intPos, 1)         End If     Next     highlight = strTemp End 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=Str     end 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=Str End 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=Str End 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), "<br/>")         HTMLEncode = Str     End If End 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 If End 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, "<br/>", CHR(10))         HTMLDecode = Str     End If End Function '************************************* '恢复&字符 '************************************* function ClearHTML(ByVal reString)     Dim Str:Str=reString     If Not IsNull(Str) Then         Str = Replace(Str, "&", "&")         ClearHTML = Str     End If End Function '************************************* '过滤textarea '************************************* Function UBBFilter(ByVal reString)     Dim Str:Str=reString     If Not IsNull(Str) Then         Str = Replace(Str, "</textarea>", "</textarea>")         UBBFilter = Str     End If End 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 IF End 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 Select End Function '************************************* '分页函数 '************************************* dim FirstShortCut,ShortCut FirstShortCut=false Function 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)<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="<div class=""page"" style="""&Style&"""><ul>"        'if Curpage<>1 then MultiPage=MultiPage&"<li class=""PageL""><a href="""&Url&"page=1"" class=""PageLbutton"" title=""第一页""></a></li>"         MultiPage=MultiPage&"<li class=""pageNumber"">"         if Curpage<>1 then MultiPage=MultiPage&"<a href="""&Url&"page=1"" title=""第一页"" style=""text-decoration:none""><</a> | "         if not FirstShortCut then ShortCut=" accesskey="",""" else ShortCut=""         if Curpage<>1 then MultiPage=MultiPage&"<a href="""&Url&"page="&CurPage-1&""" title=""上一页"" style=""text-decoration:none;"""&ShortCut&"></a>"         For PageI=FromPage TO ToPage             If PageI<>CurPage Then                 MultiPage=MultiPage&"<a href="""&Url&"page="&PageI&aname&""">"&PageI&"</a> | "             Else                 MultiPage=MultiPage&"<strong>"&PageI&"</strong>"                 if PageI<>Pages then MultiPage=MultiPage&" | "             End If         Next         if not FirstShortCut then ShortCut=" accesskey="".""" else ShortCut=""         if Curpage<>pages then MultiPage=MultiPage&"<a href="""&Url&"page="&CurPage+1&""" title=""下一页"" style=""text-decoration:none"""&ShortCut&"></a>"         if Curpage<>pages then MultiPage=MultiPage&"<a href="""&Url&"page="&Pages&aname&""" title=""最后一页"" style=""text-decoration:none"">></a>"         MultiPage=MultiPage&"</li>"         'If Int(Pages)>Int(Page) Then         '    MultiPage=MultiPage&"<li>...</li><li><a href="""&Url&"page="&Pages&aname&""">"&pages&"</a></li>"         'End If         'if Curpage<>pages then MultiPage=MultiPage&"<li class=""PageR""><a href="""&Url&"page="&Pages&aname&""" class=""PageRbutton"" title=""最后一页""></a></li>"         MultiPage=MultiPage&"</ul></div>" '    End If FirstShortCut=true End 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="<br/>" Then              ts=ts+1           End If       l=Lcase(Mid(Content,i,4))           If l="<br>" Then              ts=ts+1           End If       l=Lcase(Mid(Content,i,3))           If l="<p>" 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=Content End Function