首页 > > 网络编程 > Asp编程 >

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

2009-05-12 15:14:59来源：未知阅读 ()

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

%>

标签：

版权申明：本站文章部分自网络，如有侵权，请联系：west999com@outlook.com
特别注意：本站所有转载文章言论不代表本站观点，本站所提供的摄影照片，插画，设计作品，如需使用，请与原作者联系，版权归原作者所有