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

ajax · 发表于 2008-10-14 18:20:19

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

%>

		自动登录	找回密码
密码			注册

全国各地医院查询	重量转换换算	RGB颜色查询	交通标志大全	各类快递查询
简体繁体转换	黄金价格实时走势	万年历查询	实时汇率转换	列车时刻查询
在线翻译工具	CSS中文手册	HTML学习教程	MySQL中文手册	JavaScript中文手册
PHP安全基础手册	PHP5面向对象编程教程	正则表达式系统教程	SQL Server精华	Apache 2.2 中文手册
DOS命令全集指南	windows脚本技术中文版	股票行情查询	历史上的今天	邮编区号查询
长度转换换算	货币汇率转换	常用电话号码	体育彩票查询	手机位置查询
域名Whois信息查询	谷歌PR值查询	台州网站建设	台州网站开发	台州域名注册
天气预报查询	长度转换换算器	在线电子地图	车牌号码查询	中国百家姓查询