推荐：ASP判断数据库值是否为空的通用函数由于各种字段属性不同，判断字段是否为空的方法也各异． 下面是一个通用函数，免去了还要看字段类型之苦． 'Check a variable isn't empty Function IsBlank(ByRef TempVar) 'by default, assume it's not blank IsBlank = False 'now check by variable t
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_CookieNameuserOnlineKey)<>Application(space_CookieName_onlineCountKey) then
Application.Lock()
Application(space_CookieName_onlineCount)=Application(space_CookieName_onlineCount)+1
Application.Unlock()
Session(space_CookieNameuserOnlineKey)=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将数据库中的数据导出到EXCEL表中ASP实例代码，直接将数据库中的数据导出到EXCEL电子表中。 !--#include file=../conn.asp-- % dim s,sql,filename,fs,myfile,x Set fs = server.CreateObject(scripting.filesystemobject) '--假设你想让生成的EXCEL文件做如下的存放 filename = Server.