ASP开发中有用的函数（function）集合(3)
作者：站长整理 来源：网页教学网 发布时间：2008-10-14 17:20:00
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
％>
0
投稿猜你喜欢
- SQL Server会把经常使用到的数据缓存在内存里(就是数据页缓存)，用以提高数据访问速度。因为磁盘访问速度远远低于内存，所以减少磁盘访问
- 我设计第一篇网页的时候，就遇到了字体的设置问题。我发现如果用软件约定的字体大小，则显示效果会很难看的。我是用FrontPage2000作网页
- 今天处理了一个日期选择器的ie和ff的兼容问题，本来这种情况就很难找错误，找了好久才把错误定位到js中创建元素的方法document.cre
- 第一种情况:有RAID，还需要做数据库备份吗?回答:需要。有了RAID，万一部份磁盘损坏，可以修复数据库，有的情况下数据库甚至可以继续使用。
- 如果你看到别人写trim函数是用循环而不用正则表达式来写，请不要取笑，也许，他们就是高手。如果你很自信你的trim函数效率很高，请看完本文再
js运行效果，含公历农历，生肖及节日的javascript日历代码：<html><head><meta htt- jQuery之父John Resig写过一篇《Sub-Pixel Problems in CSS》，一个50px宽的div中有4个float
- 据国外媒体报道，相较于IE8浏览器，微软最新一代浏览器IE9的最大改进就是硬件加速HTML5。微软承诺，通过利用IE9中的硬件加速功能，开发
- 一、 在数据库排序查询优化上的差异。在讲解这个内容之前，为了读者能够清楚我讲的内容，我要先谈一个概念。命中率，它是指从内存中取得数据而不从磁
- 在表中有两个字段：id_no (varchar) , in_date (datetime) ，把in_date相同的记录的in_date依次
- 工欲善其事，必先利其器。作为更专业的前端工程师，我们需要强劲的IDE协助我们写出规范、美观、漂亮的JavaScript代码，首先要作的就是对
- 使用MySQL，安全问题不能不注意。以下是MySQL提示的23个注意事项：1。如果客户端和服务器端的连接需要跨越并通过不可信任的网络，那么就
- 一组常用的弹出窗口用法，以下代码集合常用的弹出窗口用法。1、最基本的弹出窗口代码<SCRIPT LANGUAGE="
- 如何显示数据库里的图片？asp调用数据库中的图片并显示。怎样把数据库里的图片显示出来？我们以gif格式的图片为例，代码如下：showimag
- asp之家注：防止表单重复提交的方法，在客户端其实很容易实现，只要使用js让用户第一次点击提交按钮后，把提交按钮设置为disabled，这样
- 用window.open打开的窗口中，有时候session变量会丢掉，给asp编程带来的一定的麻烦。用参数传递解决它：<DIV&nbs
- 很实用的过滤重复数据的asp代码，函数如下：<％'**************************************
- 没什么说的，就是生成随机数而已！！相关文章推荐：8个asp生成随机字符的函数<％ Function gen_key(digi
- Ajax 技术改变了大型商业 Web 应用程序的外观，但是许多较小的 Web 站点都不具备足够的资源重新构建完整的用户界面（UI）。Ajax
- 设计是简单的如果你知道要放的东西该放到哪。曾经在某个电子杂志里看到一篇关于如何在平面设计中偷懒的文章，引发了我的一些思考，在平面设计中有这么
