亲宝软件园·资讯

展开

pjblog2的参数

人气:0
想了解pjblog2的参数的相关内容吗,在本文为您仔细讲解的相关知识和一些Code实例,欢迎阅读和指正,我们先划重点:pjblog2的参数,下面大家一起来学习吧。
<% 
'===============================================================
'  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

'*************************************
'切割内容 - 按字符分割
'*************************************
Function CutStr(byVal Str,byVal StrLen)
    Dim l,t,c,i
    If IsNull(Str) Then CutStr="":Exit Function
    l=Len(str)
    StrLen=int(StrLen)
    t=0
    For i=1 To l
        c=Asc(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

'*************************************
'Trackback Function
'*************************************
Function Trackback(trackback_url, url, title, excerpt, blog_name) 
    Dim query_string, objXMLHTTP

    query_string = "title="&cutStr(Server.URLEncode(title),100)&"&url="&Server.URLEncode(url)&"&blog_name="&Server.URLEncode(blog_name)&"&excerpt="&cutStr(Server.URLEncode(excerpt), 252)
    Set objXMLHTTP = Server.CreateObject(getXMLHTTP)

    objXMLHTTP.Open "POST", trackback_url, false
    objXMLHTTP.setRequestHeader "Content-Type","application/x-www-Form-urlencoded"

    'HAndling timeout
    On Error Resume Next
    objXMLHTTP.Send query_string
    err.clear

    Set objXMLHTTP = Nothing
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,"")
    re.Pattern="\[quote=(.[^\]]*)\](.[^\]]*?)\[\/quote\]"
    strContent= re.Replace(strContent,"")
    Set re=Nothing
    DelQuote=strContent
End Function

'*************************************
'获取客户端IP
'*************************************
function getIP() 
         dim strIP,IP_Ary,strIP_list
         strIP_list=Replace(Request.ServerVariables("HTTP_X_FORWARDED_FOR"),"'","")

         If InStr(strIP_list,",")<>0 Then
            IP_Ary = Split(strIP_list,",")
            strIP = IP_Ary(0)
         Else
            strIP = strIP_list
         End IF

         If strIP=Empty Then strIP=Replace(Request.ServerVariables("REMOTE_ADDR"),"'","")
         getIP=strIP
End Function


'*************************************
'获取客户端浏览器信息
'*************************************
function getBrowser(strUA) 
 dim arrInfo,strType,temp1,temp2
 strType=""
 strUA=LCase(strUA)
 arrInfo=Array("Unkown","Unkown")
 '浏览器判断
    if Instr(strUA,"mozilla")>0 then arrInfo(0)="Mozilla"
    if Instr(strUA,"icab")>0 then arrInfo(0)="iCab"
    if Instr(strUA,"lynx")>0 then arrInfo(0)="Lynx"
    if Instr(strUA,"links")>0 then arrInfo(0)="Links"
    if Instr(strUA,"elinks")>0 then arrInfo(0)="ELinks"
    if Instr(strUA,"jbrowser")>0 then arrInfo(0)="JBrowser"
    if Instr(strUA,"konqueror")>0 then arrInfo(0)="konqueror"
    if Instr(strUA,"wget")>0 then arrInfo(0)="wget"
    if Instr(strUA,"ask jeeves")>0 or Instr(strUA,"teoma")>0 then arrInfo(0)="Ask Jeeves/Teoma"
    if Instr(strUA,"wget")>0 then arrInfo(0)="wget"
    if Instr(strUA,"opera")>0 then arrInfo(0)="opera"

    if Instr(strUA,"gecko")>0 then 
      strType="[Gecko]"
      arrInfo(0)="Mozilla"
      if Instr(strUA,"aol")>0 then arrInfo(0)="AOL"
      if Instr(strUA,"netscape")>0 then arrInfo(0)="Netscape"
      if Instr(strUA,"firefox")>0 then arrInfo(0)="FireFox"
      if Instr(strUA,"chimera")>0 then arrInfo(0)="Chimera"
      if Instr(strUA,"camino")>0 then arrInfo(0)="Camino"
      if Instr(strUA,"galeon")>0 then arrInfo(0)="Galeon"
      if Instr(strUA,"k-meleon")>0 then arrInfo(0)="K-Meleon"
      arrInfo(0)=arrInfo(0)+strType
   end if

   if Instr(strUA,"bot")>0 or Instr(strUA,"crawl")>0 then 
      strType="[Bot/Crawler]"
      arrInfo(0)=""
      if Instr(strUA,"grub")>0 then arrInfo(0)="Grub"
      if Instr(strUA,"googlebot")>0 then arrInfo(0)="GoogleBot"
      if Instr(strUA,"msnbot")>0 then arrInfo(0)="MSN Bot"
      if Instr(strUA,"slurp")>0 then arrInfo(0)="Yahoo! Slurp"
      arrInfo(0)=arrInfo(0)+strType
  end if

  if Instr(strUA,"applewebkit")>0 then 
      strType="[AppleWebKit]"
      arrInfo(0)=""
      if Instr(strUA,"omniweb")>0 then arrInfo(0)="OmniWeb"
      if Instr(strUA,"safari")>0 then arrInfo(0)="Safari"
      arrInfo(0)=arrInfo(0)+strType
  end if 

  if Instr(strUA,"msie")>0 then 
      strType="[MSIE"
      temp1=mid(strUA,(Instr(strUA,"msie")+4),6)
      temp2=Instr(temp1,";")
      temp1=left(temp1,temp2-1)
      strType=strType & temp1 &"]"
      arrInfo(0)="Internet Explorer"
      if Instr(strUA,"msn")>0 then arrInfo(0)="MSN"
      if Instr(strUA,"aol")>0 then arrInfo(0)="AOL"
      if Instr(strUA,"webtv")>0 then arrInfo(0)="WebTV"
      if Instr(strUA,"myie2")>0 then arrInfo(0)="MyIE2"
      if Instr(strUA,"maxthon")>0 then arrInfo(0)="Maxthon"
      if Instr(strUA,"gosurf")>0 then arrInfo(0)="GoSurf"
      if Instr(strUA,"netcaptor")>0 then arrInfo(0)="NetCaptor"
      if Instr(strUA,"sleipnir")>0 then arrInfo(0)="Sleipnir"
      if Instr(strUA,"avant browser")>0 then arrInfo(0)="AvantBrowser"
      if Instr(strUA,"greenbrowser")>0 then arrInfo(0)="GreenBrowser"
      if Instr(strUA,"slimbrowser")>0 then arrInfo(0)="SlimBrowser"
      arrInfo(0)=arrInfo(0)+strType
   end if

 '操作系统判断
    if Instr(strUA,"windows")>0 then arrInfo(1)="Windows"
    if Instr(strUA,"windows ce")>0 then arrInfo(1)="Windows CE"
    if Instr(strUA,"windows 95")>0 then arrInfo(1)="Windows 95"
    if Instr(strUA,"win98")>0 then arrInfo(1)="Windows 98"
    if Instr(strUA,"windows 98")>0 then arrInfo(1)="Windows 98"
    if Instr(strUA,"windows 2000")>0 then arrInfo(1)="Windows 2000"
    if Instr(strUA,"windows xp")>0 then arrInfo(1)="Windows XP"

    if Instr(strUA,"windows nt")>0 then
      arrInfo(1)="Windows NT"
      if Instr(strUA,"windows nt 5.0")>0 then arrInfo(1)="Windows 2000"
      if Instr(strUA,"windows nt 5.1")>0 then arrInfo(1)="Windows XP"
      if Instr(strUA,"windows nt 5.2")>0 then arrInfo(1)="Windows 2003"
    end if
    if Instr(strUA,"x11")>0 or Instr(strUA,"unix")>0 then arrInfo(1)="Unix"
    if Instr(strUA,"sunos")>0 or Instr(strUA,"sun os")>0 then arrInfo(1)="SUN OS"
    if Instr(strUA,"powerpc")>0 or Instr(strUA,"ppc")>0 then arrInfo(1)="PowerPC"
    if Instr(strUA,"macintosh")>0 then arrInfo(1)="Mac"
    if Instr(strUA,"mac osx")>0 then arrInfo(1)="MacOSX"
    if Instr(strUA,"freebsd")>0 then arrInfo(1)="FreeBSD"
    if Instr(strUA,"linux")>0 then arrInfo(1)="Linux"
    if Instr(strUA,"palmsource")>0 or Instr(strUA,"palmos")>0 then arrInfo(1)="PalmOS"
    if Instr(strUA,"wap ")>0 then arrInfo(1)="WAP"

 'arrInfo(0)=strUA 
 getBrowser=arrInfo
end function

'*************************************
'计算随机数
'*************************************
function randomStr(intLength)
    dim strSeed,seedLength,pos,str,i
    strSeed = "abcdefghijklmnopqrstuvwxyz1234567890"
    seedLength=len(strSeed)
    str=""
    Randomize
    for i=1 to intLength
     str=str+mid(strSeed,int(seedLength*rnd)+1,1)
    next
    randomStr=str
end function

'*************************************
'自动闭合UBB
'*************************************
function closeUBB(strContent)
  dim arrTags,i,OpenPos,ClosePos,re,strMatchs,j,Match
    Set re=new RegExp
    re.IgnoreCase =True
    re.Global=True
    arrTags=array("code","quote","list","color","align","font","size","b","i","u","html")
  for i=0 to ubound(arrTags)
   OpenPos=0
   ClosePos=0

   re.Pattern="\["+arrTags(i)+"(=[^\[\]]+|)\]"
   Set strMatchs=re.Execute(strContent)
   For Each Match in strMatchs
    OpenPos=OpenPos+1
   next
   re.Pattern="\[/"+arrTags(i)+"\]"
   Set strMatchs=re.Execute(strContent)
   For Each Match in strMatchs
    ClosePos=ClosePos+1
   next
   for j=1 to OpenPos-ClosePos
      strContent=strContent+"[/"+arrTags(i)+"]"
   next
  next
closeUBB=strContent
end function

'*************************************
'自动闭合HTML
'*************************************
function closeHTML(strContent)
  dim arrTags,i,OpenPos,ClosePos,re,strMatchs,j,Match
    Set re=new RegExp
    re.IgnoreCase =True
    re.Global=True
    arrTags=array("p","div","span","table","ul","font","b","u","i","h1","h2","h3","h4","h5","h6")
  for i=0 to ubound(arrTags)
   OpenPos=0
   ClosePos=0

   re.Pattern="\<"+arrTags(i)+"( [^\<\>]+|)\>"
   Set strMatchs=re.Execute(strContent)
   For Each Match in strMatchs
    OpenPos=OpenPos+1
   next
   re.Pattern="\</"+arrTags(i)+"\>"
   Set strMatchs=re.Execute(strContent)
   For Each Match in strMatchs
    ClosePos=ClosePos+1
   next
   for j=1 to OpenPos-ClosePos
      strContent=strContent+"</"+arrTags(i)+">"
   next
  next
closeHTML=strContent
end function

'*************************************
'读取文件
'*************************************
Function LoadFromFile(ByVal File)
    Dim objStream
    Dim RText
    RText=array(0,"")
    On Error Resume Next
    Set objStream = Server.CreateObject("ADODB.Stream")
    If Err Then 
        RText=array(Err.Number,Err.Description)
        LoadFromFile=RText
        Err.Clear
        exit function
    End If
    With objStream
        .Type = 2
        .Mode = 3
        .Open
        .Charset = "utf-8"
        .Position = objStream.Size
        .LoadFromFile Server.MapPath(File)
        If Err.Number<>0 Then
           RText=array(Err.Number,Err.Description)
           LoadFromFile=RText
           Err.Clear
           exit function
        End If
        RText=array(0,.ReadText)
        .Close
    End With
    LoadFromFile=RText
    Set objStream = Nothing
End Function

'*************************************
'保存文件
'*************************************
Function SaveToFile(ByVal strBody,ByVal File)
    Dim objStream
    Dim RText
    RText=array(0,"")
    On Error Resume Next
    Set objStream = Server.CreateObject("ADODB.Stream")
    If Err Then 
        RText=array(Err.Number,Err.Description)
        Err.Clear
        exit function
    End If
    With objStream
        .Type = 2
        .Open
        .Charset = "utf-8"
        .Position = objStream.Size
        .WriteText = strBody
        .SaveToFile Server.MapPath(File),2
        .Close
    End With
    RText=array(0,"保存文件成功!")
    SaveToFile=RText
    Set objStream = Nothing
End Function

'*************************************
'数据库添加修改操作
'*************************************
function DBQuest(table,DBArray,Action)
 dim AddCount,TempDB,i,v
 if Action<>"insert" or Action<>"update" then Action="insert"
 if Action="insert" then v=2 else v=3
 if not IsArray(DBArray) then
   DBQuest=-1
   exit function
 else
   Set TempDB=Server.CreateObject("ADODB.RecordSet")
   On Error Resume Next
   TempDB.Open table,Conn,1,v
   if err then
    DBQuest=-2
    exit function
   end if
   if Action="insert" then TempDB.addNew
   AddCount=UBound(DBArray,1)
   for i=0 to AddCount
    TempDB(DBArray(i)(0))=DBArray(i)(1)
   next
   TempDB.update
   TempDB.close
   set TempDB=nothing
   DBQuest=0
 end if
end Function

'*************************************
'检测系统组件是否安装
'*************************************
Function CheckObjInstalled(strClassString)
    On Error Resume Next
    Dim Temp
    Err = 0
    Dim TmpObj
    Set TmpObj = Server.CreateObject(strClassString)
    Temp = Err
    IF Temp = 0 OR Temp = -2147221477 Then
        CheckObjInstalled=true
    ElseIF Temp = 1 OR Temp = -2147221005 Then
        CheckObjInstalled=false
    End IF
    Err.Clear
    Set TmpObj = Nothing
    Err = 0
End Function

'*************************************
'判断服务器Microsoft.XMLDOM
'*************************************
Function getXMLDOM
    On Error Resume Next
    Dim Temp
    getXMLDOM="Microsoft.XMLDOM"
    Err = 0
    Dim TmpObj
    Set TmpObj = Server.CreateObject(getXMLDOM)
    Temp = Err
    IF Temp = 1 OR Temp = -2147221005 Then
        getXMLDOM="Msxml2.DOMDocument.5.0"
    End IF
    Err.Clear
    Set TmpObj = Nothing
    Err = 0
end function

'*************************************
'判断服务器MSXML2.ServerXMLHTTP
'*************************************
Function getXMLHTTP
    On Error Resume Next
    Dim Temp
    getXMLHTTP="MSXML2.ServerXMLHTTP"
    Err = 0
    Dim TmpObj
    Set TmpObj = Server.CreateObject(getXMLHTTP)
    Temp = Err
    IF Temp = 1 OR Temp = -2147221005 Then
        getXMLHTTP="Msxml2.ServerXMLHTTP.5.0"
    End IF
    Err.Clear
    Set TmpObj = Nothing
    Err = 0
end function

'*************************************
'检查插件是否成功安装
'*************************************
Function Checkplugins 
   Dim PlugS,Plug,PlugItem
   Checkplugins=-1
    PlugS=Split(function_Plugin,"$*$")
    For Each Plug In PlugS
      PlugItem = Split(Plug,"%|%")
      If Getplugins=PlugItem(0) Then 
        Checkplugins=PlugItem
        Exit Function
      End If
    Next
End Function 

'*************************************
'显示帮助信息
'*************************************
sub showmsg(title,des,icon,showType)
 on error resume next
 Conn.close
 set Conn=nothing
 Err.Clear
 session(CookieName&"_ShowMsg")=true
 session(CookieName&"_title")=title
 session(CookieName&"_des")=des
 session(CookieName&"_icon")=icon
 'icon 类型
 'MessageIcon
 'ErrorIcon
 'WarningIcon
 'QuestionIcon
 if showType="plugins" then
   Response.Redirect("../../showmsg.asp")
 else
   Response.Redirect("showmsg.asp")
 end if
end sub

'*************************************
'垃圾关键字过滤
'*************************************
function filterSpam(str,path)
  on error resume next
     filterSpam = false
     dim spamXml,spamItem
     Set spamXml = Server.CreateObject(getXMLDOM)
       If Err Then  
           Err.clear
           exit function
       end if
     spamXml.async = false  
     spamXml.load(Server.MapPath(path))
     if spamXml.parseerror.errorcode=0 then
       For Each spamItem in spamXml.selectNodes("//key")
               if InStr(Lcase(str),Lcase(spamItem.text))<>0 then
                  filterSpam = true
                  exit function
               end if
       next
     end if
     set spamXml=nothing
end function

%> p;   if Instr(strUA,"links")>0 then arrInfo(0)="Links"
    if Instr(strUA,"elinks")>0 then arrInfo(0)="ELinks"
    if Instr(strUA,"jbrowser")>0 then arrInfo(0)="JBrowser"
    if Instr(strUA,"konqueror")>0 then arrInfo(0)="konqueror"
    if Instr(strUA,"wget")>0 then arrInfo(0)="wget"
    if Instr(strUA,"ask jeeves")>0 or Instr(strUA,"teoma")>0 then arrInfo(0)="Ask Jeeves/Teoma"
    if Instr(strUA,"wget")>0 then arrInfo(0)="wget"
    if Instr(strUA,"opera")>0 then arrInfo(0)="opera"

    if Instr(strUA,"gecko")>0 then 
      strType="[Gecko]"
      arrInfo(0)="Mozilla"
      if Instr(strUA,"aol")>0 then arrInfo(0)="AOL"
      if Instr(strUA,"netscape")>0 then arrInfo(0)="Netscape"
      if Instr(strUA,"firefox")>0 then arrInfo(0)="FireFox"
      if Instr(strUA,"chimera")>0 then arrInfo(0)="Chimera"
      if Instr(strUA,"camino")>0 then arrInfo(0)="Camino"
      if Instr(strUA,"galeon")>0 then arrInfo(0)="Galeon"
      if Instr(strUA,"k-meleon")>0 then arrInfo(0)="K-Meleon"
      arrInfo(0)=arrInfo(0)+strType
   end if

   if Instr(strUA,"bot")>0 or Instr(strUA,"crawl")>0 then 
      strType="[Bot/Crawler]"
      arrInfo(0)=""
      if Instr(strUA,"grub")>0 then arrInfo(0)="Grub"
      if Instr(strUA,"googlebot")>0 then arrInfo(0)="GoogleBot"
      if Instr(strUA,"msnbot")>0 then arrInfo(0)="MSN Bot"
      if Instr(strUA,"slurp")>0 then arrInfo(0)="Yahoo! Slurp"
      arrInfo(0)=arrInfo(0)+strType
  end if

  if Instr(strUA,"applewebkit")>0 then 
      strType="[AppleWebKit]"
      arrInfo(0)=""
      if Instr(strUA,"omniweb")>0 then arrInfo(0)="OmniWeb"
      if Instr(strUA,"safari")>0 then arrInfo(0)="Safari"
      arrInfo(0)=arrInfo(0)+strType
  end if 

  if Instr(strUA,"msie")>0 then 
      strType="[MSIE"
      temp1=mid(strUA,(Instr(strUA,"msie")+4),6)
      temp2=Instr(temp1,";")
      temp1=left(temp1,temp2-1)
      strType=strType & temp1 &"]"
      arrInfo(0)="Internet Explorer"
      if Instr(strUA,"msn")>0 then arrInfo(0)="MSN"
      if Instr(strUA,"aol")>0 then arrInfo(0)="AOL"
      if Instr(strUA,"webtv")>0 then arrInfo(0)="WebTV"
      if Instr(strUA,"myie2")>0 then arrInfo(0)="MyIE2"
      if Instr(strUA,"maxthon")>0 then arrInfo(0)="Maxthon"
      if Instr(strUA,"gosurf")>0 then arrInfo(0)="GoSurf"
      if Instr(strUA,"netcaptor")>0 then arrInfo(0)="NetCaptor"
      if Instr(strUA,"sleipnir")>0 then arrInfo(0)="Sleipnir"
      if Instr(strUA,"avant browser")>0 then arrInfo(0)="AvantBrowser"
      if Instr(strUA,"greenbrowser")>0 then arrInfo(0)="GreenBrowser"
      if Instr(strUA,"slimbrowser")>0 then arrInfo(0)="SlimBrowser"
      arrInfo(0)=arrInfo(0)+strType
   end if

 '操作系统判断
    if Instr(strUA,"windows")>0 then arrInfo(1)="Windows"
    if Instr(strUA,"windows ce")>0 then arrInfo(1)="Windows CE"
    if Instr(strUA,"windows 95")>0 then arrInfo(1)="Windows 95"
    if Instr(strUA,"win98")>0 then arrInfo(1)="Windows 98"
    if Instr(strUA,"windows 98")>0 then arrInfo(1)="Windows 98"
    if Instr(strUA,"windows 2000")>0 then arrInfo(1)="Windows 2000"
    if Instr(strUA,"windows xp")>0 then arrInfo(1)="Windows XP"

    if Instr(strUA,"windows nt")>0 then
      arrInfo(1)="Windows NT"
      if Instr(strUA,"windows nt 5.0")>0 then arrInfo(1)="Windows 2000"
      if Instr(strUA,"windows nt 5.1")>0 then arrInfo(1)="Windows XP"
      if Instr(strUA,"windows nt 5.2")>0 then arrInfo(1)="Windows 2003"
    end if
    if Instr(strUA,"x11")>0 or Instr(strUA,"unix")>0 then arrInfo(1)="Unix"
    if Instr(strUA,"sunos")>0 or Instr(strUA,"sun os")>0 then arrInfo(1)="SUN OS"
    if Instr(strUA,"powerpc")>0 or Instr(strUA,"ppc")>0 then arrInfo(1)="PowerPC"
    if Instr(strUA,"macintosh")>0 then arrInfo(1)="Mac"
    if Instr(strUA,"mac osx")>0 then arrInfo(1)="MacOSX"
    if Instr(strUA,"freebsd")>0 then arrInfo(1)="FreeBSD"
    if Instr(strUA,"linux")>0 then arrInfo(1)="Linux"
    if Instr(strUA,"palmsource")>0 or Instr(strUA,"palmos")>0 then arrInfo(1)="PalmOS"
    if Instr(strUA,"wap ")>0 then arrInfo(1)="WAP"

 'arrInfo(0)=strUA 
 getBrowser=arrInfo
end function

'*************************************
'计算随机数
'*************************************
function randomStr(intLength)
    dim strSeed,seedLength,pos,str,i
    strSeed = "abcdefghijklmnopqrstuvwxyz1234567890"
    seedLength=len(strSeed)
    str=""
    Randomize
    for i=1 to intLength
     str=str+mid(strSeed,int(seedLength*rnd)+1,1)
    next
    randomStr=str
end function

'*************************************
'自动闭合UBB
'*************************************
function closeUBB(strContent)
  dim arrTags,i,OpenPos,ClosePos,re,strMatchs,j,Match
    Set re=new RegExp
    re.IgnoreCase =True
    re.Global=True
    arrTags=array("code","quote","list","color","align","font","size","b","i","u","html")
  for i=0 to ubound(arrTags)
   OpenPos=0
   ClosePos=0

   re.Pattern="\["+arrTags(i)+"(=[^\[\]]+|)\]"
   Set strMatchs=re.Execute(strContent)
   For Each Match in strMatchs
    OpenPos=OpenPos+1
   next
   re.Pattern="\[/"+arrTags(i)+"\]"
   Set strMatchs=re.Execute(strContent)
   For Each Match in strMatchs
    ClosePos=ClosePos+1
   next
   for j=1 to OpenPos-ClosePos
      strContent=strContent+"[/"+arrTags(i)+"]"
   next
  next
closeUBB=strContent
end function

'*************************************
'自动闭合HTML
'*************************************
function closeHTML(strContent)
  dim arrTags,i,OpenPos,ClosePos,re,strMatchs,j,Match
    Set re=new RegExp
    re.IgnoreCase =True
    re.Global=True
    arrTags=array("p","div","span","table","ul","font","b","u","i","h1","h2","h3","h4","h5","h6")
  for i=0 to ubound(arrTags)
   OpenPos=0
   ClosePos=0

   re.Pattern="\<"+arrTags(i)+"( [^\<\>]+|)\>"
   Set strMatchs=re.Execute(strContent)
   For Each Match in strMatchs
    OpenPos=OpenPos+1
   next
   re.Pattern="\</"+arrTags(i)+"\>"
   Set strMatchs=re.Execute(strContent)
   For Each Match in strMatchs
    ClosePos=ClosePos+1
   next
   for j=1 to OpenPos-ClosePos
      strContent=strContent+"</"+arrTags(i)+">"
   next
  next
closeHTML=strContent
end function

'*************************************
'读取文件
'*************************************
Function LoadFromFile(ByVal File)
    Dim objStream
    Dim RText
    RText=array(0,"")
    On Error Resume Next
    Set objStream = Server.CreateObject("ADODB.Stream")
    If Err Then 
        RText=array(Err.Number,Err.Description)
        LoadFromFile=RText
        Err.Clear
        exit function
    End If
    With objStream
        .Type = 2
        .Mode = 3
        .Open
        .Charset = "utf-8"
        .Position = objStream.Size
        .LoadFromFile Server.MapPath(File)
        If Err.Number<>0 Then
           RText=array(Err.Number,Err.Description)
           LoadFromFile=RText
           Err.Clear
           exit function
        End If
        RText=array(0,.ReadText)
        .Close
    End With
    LoadFromFile=RText
    Set objStream = Nothing
End Function

'*************************************
'保存文件
'*************************************
Function SaveToFile(ByVal strBody,ByVal File)
    Dim objStream
    Dim RText
    RText=array(0,"")
    On Error Resume Next
    Set objStream = Server.CreateObject("ADODB.Stream")
    If Err Then 
        RText=array(Err.Number,Err.Description)
        Err.Clear
        exit function
    End If
    With objStream
        .Type = 2
        .Open
        .Charset = "utf-8"
        .Position = objStream.Size
        .WriteText = strBody
        .SaveToFile Server.MapPath(File),2
        .Close
    End With
    RText=array(0,"保存文件成功!")
    SaveToFile=RText
    Set objStream = Nothing
End Function

'*************************************
'数据库添加修改操作
'*************************************
function DBQuest(table,DBArray,Action)
 dim AddCount,TempDB,i,v
 if Action<>"insert" or Action<>"update" then Action="insert"
 if Action="insert" then v=2 else v=3
 if not IsArray(DBArray) then
   DBQuest=-1
   exit function
 else
   Set TempDB=Server.CreateObject("ADODB.RecordSet")
   On Error Resume Next
   TempDB.Open table,Conn,1,v
   if err then
    DBQuest=-2
    exit function
   end if
   if Action="insert" then TempDB.addNew
   AddCount=UBound(DBArray,1)
   for i=0 to AddCount
    TempDB(DBArray(i)(0))=DBArray(i)(1)
   next
   TempDB.update
   TempDB.close
   set TempDB=nothing
   DBQuest=0
 end if
end Function

'*************************************
'检测系统组件是否安装
'*************************************
Function CheckObjInstalled(strClassString)
    On Error Resume Next
    Dim Temp
    Err = 0
    Dim TmpObj
    Set TmpObj = Server.CreateObject(strClassString)
    Temp = Err
    IF Temp = 0 OR Temp = -2147221477 Then
        CheckObjInstalled=true
    ElseIF Temp = 1 OR Temp = -2147221005 Then
        CheckObjInstalled=false
    End IF
    Err.Clear
    Set TmpObj = Nothing
    Err = 0
End Function

'*************************************
'判断服务器Microsoft.XMLDOM
'*************************************
Function getXMLDOM
    On Error Resume Next
    Dim Temp
    getXMLDOM="Microsoft.XMLDOM"
    Err = 0
    Dim TmpObj
    Set TmpObj = Server.CreateObject(getXMLDOM)
    Temp = Err
    IF Temp = 1 OR Temp = -2147221005 Then
        getXMLDOM="Msxml2.DOMDocument.5.0"
    End IF
    Err.Clear
    Set TmpObj = Nothing
    Err = 0
end function

'*************************************
'判断服务器MSXML2.ServerXMLHTTP
'*************************************
Function getXMLHTTP
    On Error Resume Next
    Dim Temp
    getXMLHTTP="MSXML2.ServerXMLHTTP"
    Err = 0
    Dim TmpObj
    Set TmpObj = Server.CreateObject(getXMLHTTP)
    Temp = Err
    IF Temp = 1 OR Temp = -2147221005 Then
        getXMLHTTP="Msxml2.ServerXMLHTTP.5.0"
    End IF
    Err.Clear
    Set TmpObj = Nothing
    Err = 0
end function

'*************************************
'检查插件是否成功安装
'*************************************
Function Checkplugins 
   Dim PlugS,Plug,PlugItem
   Checkplugins=-1
    PlugS=Split(function_Plugin,"$*$")
    For Each Plug In PlugS
      PlugItem = Split(Plug,"%|%")
      If Getplugins=PlugItem(0) Then 
        Checkplugins=PlugItem
        Exit Function
      End If
    Next
End Function 

'*************************************
'显示帮助信息
'*************************************
sub showmsg(title,des,icon,showType)
 on error resume next
 Conn.close
 set Conn=nothing
 Err.Clear
 session(CookieName&"_ShowMsg")=true
 session(CookieName&"_title")=title
 session(CookieName&"_des")=des
 session(CookieName&"_icon")=icon
 'icon 类型
 'MessageIcon
 'ErrorIcon
 'WarningIcon
 'QuestionIcon
 if showType="plugins" then
   Response.Redirect("../../showmsg.asp")
 else
   Response.Redirect("showmsg.asp")
 end if
end sub

'*************************************
'垃圾关键字过滤
'*************************************
function filterSpam(str,path)
  on error resume next
     filterSpam = false
     dim spamXml,spamItem
     Set spamXml = Server.CreateObject(getXMLDOM)
       If Err Then  
           Err.clear
           exit function
       end if
     spamXml.async = false  
     spamXml.load(Server.MapPath(path))
     if spamXml.parseerror.errorcode=0 then
       For Each spamItem in spamXml.selectNodes("//key")
               if InStr(Lcase(str),Lcase(spamItem.text))<>0 then
                  filterSpam = true
                  exit function
               end if
       next
     end if
     set spamXml=nothing
end function

%>

加载全部内容

相关教程
猜你喜欢
用户评论