<%       
’*************************************      
’防止外部提交      
’*************************************      
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 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 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(32), " ")      
        Str = Replace(Str, CHR(39), "’")      
        Str = Replace(Str, CHR(34), """)      
        Str = Replace(Str, CHR(13), "")      
        Str = Replace(Str, CHR(10), "<br/>")      
        HTMLEncode = 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(32))      
        Str = Replace(Str, "’", CHR(39))      
        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    分页函数      
’*************************************      
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     
     
’*************************************      
’删除引用标签      
’*************************************      
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      
        
’*********************************************************      
’ 目的：    检查正则式      
’ 输入：    id      
’ 返回：    成功为True      
’*********************************************************      
Function CheckRegExp(source,para)      
     
    If para="[username]" Then     
        para="^[.A-Za-z0-9/u4e00-/u9fa5]+$"     
    End If     
    If para="[password]" Then     
        para="^[a-z0-9]+$"     
    End If     
    If para="[email]" Then     
        para="^([0-9a-zA-Z]([-./w]*[0-9a-zA-Z])*@([0-9a-zA-Z][-/w]*/.)+[a-zA-Z]*)$"     
    End If     
    If para="[homepage]" Then     
        para="^[a-zA-Z]+://[a-zA-z0-9/-/./]+?/*$"     
    End If     
    If para="[nojapan]" Then     
        para="[/u3040-/u30ff]+"     
    End If     
    If para="[guid]" Then     
        para="^/w{8}/-/w{4}/-/w{4}/-/w{4}/-/w{12}$"     
    End If     
     
    Dim re      
    Set re = New RegExp      
    re.Global = True     
    re.Pattern = para      
    re.IgnoreCase = False     
    CheckRegExp = re.Test(source)      
     
End Function     
     
’**********************************************      
’获取在线人数      
’**********************************************      
function getOnline      
    getOnline=1      
    if len(Application(space_CookieName"_onlineCount"))>0 then      
        if DateDiff("s",Application(space_CookieName"_userOnlineCountTime"),now())>60 then      
                Application.Lock()      
                Application(space_CookieName"_online")=Application(space_CookieName"_onlineCount")      
                Application(space_CookieName"_onlineCount")=1      
                Application(space_CookieName"_onlineCountKey")=randStr(2)      
                Application(space_CookieName"_userOnlineCountTime")=now()      
                Application.Unlock()      
        else      
                if Session(space_CookieName"userOnlineKey")<>Application(space_CookieName"_onlineCountKey") then      
                    Application.Lock()      
                    Application(space_CookieName"_onlineCount")=Application(space_CookieName"_onlineCount")+1      
                    Application.Unlock()      
                    Session(space_CookieName"userOnlineKey")=Application(space_CookieName"_onlineCountKey")      
                end if      
        end if      
    else      
        Application.Lock      
        Application(space_CookieName"_online")=1      
        Application(space_CookieName"_onlineCount")=1      
        Application(space_CookieName"_onlineCountKey")=randStr(2)      
        Application(space_CookieName"_userOnlineCountTime")=now()      
        Application.Unlock      
    end if      
    getOnline=Application(space_CookieName"_online")      
end Function