% 
'===============================================================
'  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,"$1cri#112;t ")
       re.Pattern="(s)(cript)"
    Str = re.replace(Str,"$1cri#112;t")
       re.Pattern="(o)(bject)"
    Str = re.replace(Str,"$1bj#101;ct")
       re.Pattern="(a)(pplet)"
    Str = re.replace(Str,"$1ppl#101;t")
       re.Pattern="(e)(mbed)"
    Str = re.replace(Str,"$1mb#101;d")
    Set re=Nothing
       Str = Replace(Str, ">", "gt;")
    Str = Replace(Str, "", "lt;")
    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,"'","#39;")
    Str = Replace(Str,"""","#34;")
    Dim re
    Set re=new RegExp
    re.IgnoreCase =True
    re.Global=True
    re.Pattern="(w)(here)"
    Str = re.replace(Str,"$1h#101;re")
    re.Pattern="(s)(elect)"
    Str = re.replace(Str,"$1el#101;ct")
    re.Pattern="(i)(nsert)"
    Str = re.replace(Str,"$1ns#101;rt")
    re.Pattern="(c)(reate)"
    Str = re.replace(Str,"$1r#101;ate")
    re.Pattern="(d)(rop)"
    Str = re.replace(Str,"$1ro#112;")
    re.Pattern="(a)(lter)"
    Str = re.replace(Str,"$1lt#101;r")
    re.Pattern="(d)(elete)"
    Str = re.replace(Str,"$1el#101;te")
    re.Pattern="(u)(pdate)"
    Str = re.replace(Str,"$1p#100;ate")
    re.Pattern="(\s)(or)"
    Str = re.replace(Str,"$1o#114;")
    Set re=Nothing
    CheckStr=Str
End Function

'*************************************
'恢复特殊字符
'*************************************
Function UnCheckStr(ByVal Str)
        If IsNull(Str) Then
            UnCheckStr = ""
            Exit Function 
        End If
        Str = Replace(Str,"#39;","'")
        Str = Replace(Str,"#34;","""")
        Dim re
        Set re=new RegExp
        re.IgnoreCase =True
        re.Global=True
        re.Pattern="(w)(h#101;re)"
        str = re.replace(str,"$1here")
        re.Pattern="(s)(el#101;ct)"
        str = re.replace(str,"$1elect")
        re.Pattern="(i)(ns#101;rt)"
        str = re.replace(str,"$1nsert")
        re.Pattern="(c)(r#101;ate)"
        str = re.replace(str,"$1reate")
        re.Pattern="(d)(ro#112;)"
        str = re.replace(str,"$1rop")
        re.Pattern="(a)(lt#101;r)"
        str = re.replace(str,"$1lter")
        re.Pattern="(d)(el#101;te)"
        str = re.replace(str,"$1elete")
        re.Pattern="(u)(p#100;ate)"
        str = re.replace(str,"$1pdate")
        re.Pattern="(\s)(o#114;)"
        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, ">", "gt;")
        Str = Replace(Str, "", "lt;")
        Str = Replace(Str, CHR(9), "#160;#160;#160;#160;")
        Str = Replace(Str, CHR(39), "#39;")
        Str = Replace(Str, CHR(32)CHR(32), "nbsp;nbsp;")
        Str = Replace(Str, CHR(34), "quot;")
        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, ">", "gt;")
        Str = Replace(Str, "", "lt;")
        Str = Replace(Str, CHR(9), "#160;#160;#160;#160;")
        Str = Replace(Str, CHR(39), "#39;")
        Str = Replace(Str, CHR(32)CHR(32), "nbsp;nbsp;")
        Str = Replace(Str, CHR(34), "quot;")
        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, "gt;", ">")
        Str = Replace(Str, "lt;", "")
        Str = Replace(Str, "#160;#160;#160;#160;", CHR(9))
        Str = Replace(Str, "#39;", CHR(39))
        Str = Replace(Str, "nbsp;nbsp;",CHR(32)CHR(32))
        Str = Replace(Str, "quot;", 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>", "#47textarea>")
        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,"","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,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)DateMonthDateDayDateHourDateMinuteDateSecond    
    Case "ym"
        DateToStr=Right(Year(DateTime),2)DateMonth
    Case "d"
        DateToStr=DateDay
    Case "ymd"
        DateToStr=Right(Year(DateTime),4)DateMonthDateDay
    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)" "DateDayDayEnd" "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":"DateSecondTimeZone2
    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 FromPage1 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"">lt;/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="PageIaname""">"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="Pagesaname""" title=""最后一页"" style=""text-decoration:none"">gt;/a>"
        MultiPage=MultiPage"/li>"
        'If Int(Pages)>Int(Page) Then
        '    MultiPage=MultiPage"li>.../li>li>a href="""Url"page="Pagesaname""">"pages"/a>/li>"
        'End If
        'if Curpage>pages then MultiPage=MultiPage"li class=""PageR"">a href="""Url"page="Pagesaname""" 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