% 
'===============================================================
'  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-Zd]"
    IsValidChars=True
    chkstr=re.Replace(str,"")
    if chkstrstr 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 DateHour12 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 PagePages Then
            FromPage=1
            ToPage=Pages
        Else
            If FromPage1 Then
                Topage=Curpage+1-FromPage
                FromPage=1
                If (ToPage-FromPage)Page And (ToPage-FromPage)Pages Then ToPage=Page
            ElseIF TopagePages 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 Curpage1 then MultiPage=MultiPage&"li class=""PageL""a href="""&Url&"page=1"" class=""PageLbutton"" title=""第一页""/a/li"
        MultiPage=MultiPage&"li class=""pageNumber"""
        if Curpage1 then MultiPage=MultiPage&"a href="""&Url&"page=1"" title=""第一页"" style=""text-decoration:none""/a | "
        if not FirstShortCut then ShortCut=" accesskey="",""" else ShortCut=""
        if Curpage1 then MultiPage=MultiPage&"a href="""&Url&"page="&CurPage-1&""" title=""上一页"" style=""text-decoration:none;"""&ShortCut&"/a"
        For PageI=FromPage TO ToPage
            If PageICurPage Then
                MultiPage=MultiPage&"a href="""&Url&"page="&PageI&aname&""""&PageI&"/a | "
            Else
                MultiPage=MultiPage&"strong"&PageI&"/strong"
                if PageIPages then MultiPage=MultiPage&" | "
            End If
        Next
        if not FirstShortCut then ShortCut=" accesskey="".""" else ShortCut=""
        if Curpagepages then MultiPage=MultiPage&"a href="""&Url&"page="&CurPage+1&""" title=""下一页"" style=""text-decoration:none"""&ShortCut&"/a"
        if Curpagepages 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.../lilia href="""&Url&"page="&Pages&aname&""""&pages&"/a/li"
        'End If
        'if Curpagepages 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 tsContentNums Then Exit For 
    Next
    If tsContentNums Then
        Content=Left(Content,i-1)
    End If
    SplitLines=Content
End Function
当前1/2页 12下一页