ASP编程常用的函数function集合

<%      
’*************************************     
’防止外部提交     
’*************************************     
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