网页教学网
 当前位置: 网页教学网 >> 网络编程 >> ASP编程技术 >> ASP开发中有用的函数(function)集合(3)
[ HTML ] [ FW ] [ DW ] [ FP ] [ JS ] [ XML ] [ CSS ] [ 图象 ] [ FLASH ] [ .NET ] [ ASP ] [ JSP ] [ PHP ] [ 数据 ] [ 系统 ] [ 安全 ] [ 素材 ] [ 建站 ] [ 主机 ] [ 入门 ] [ 技巧 ]

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

http://www.webjx.com  更新日期:2007-09-29 08:29  出处:网页教学网  作者:站长整理

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  
  
%>

关键词:ASP,函数
推荐给好友】【关闭】【收藏本文
最新五条评论
查看全部评论
评论总数 0
您的评论
用户名: 新注册) 密 码: 匿名:
·用户发表意见仅代表其个人意见,并且承担一切因发表内容引起的纠纷和责任
·本站管理人员有权在不通知用户的情况下删除不符合规定的评论信息或留做证据
·请客观的评价您所看到的资讯,提倡就事论事,杜绝漫骂和人身攻击等不文明行为
站内搜索
相关文章
推荐文章