ASP开发中有用的函数（function）集合(3)

ASP开发中有用的函数（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   
  
'*************************************   
'垃圾关键字过滤   
'*************************************   
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   
  
'*********************************************************   
' 目的：    检查正则式   
' 输入：    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  
  
％>