ASP的常用的自定义函数大全

<%
 '================================
 
'函数列表：
'1： 建立数据库的连接 ConnOpen(DataBaseConnectStr,DBType,Conn_object)
 '2： 断开数据库的连接 ConnClose(Conn_object)
 '3： 防止SQL注入 SafeRequest(paraName,paraType)
 '4： 格式化日期 DateFormat(dateStr,dateType)
 '5： 显示错误提示 ShowErr(errStr)
 '6： 查询字符串中特定数据 SelectStr(contentStr,patternStr,patternNum)
 '7： 过滤指定字符 Leach(contentStr,badWords)
 '8： 远程文件内容抓取 Seize(urlStr)
 '9： 数据流编码处理 BytesToBstr(body,cset)
 '10： 编码cookies codeCookie(contentStr)
 '11： 解码cookies DecodeCookie(contentStr)
 '12： 检验数据提交来源是否合法 ChkPost()
 '13： 个性化加密 MyEncrypt(StrPassword)
 '14： 禁止浏览器缓存本页 NoBuffer()
 '15： 网页格式化输入文本 HTMLEncode(fString)
 '16： 从头部截取字符串的指定长度(按字符数算) GotTopic(Str,StrLen)
 '17： 检测验证码 CheckRadomPass(RadomPass)
 '18： 生成验证码 GetCode()
 '19： 获取客户端操作系统版本 GetSystem()
 '20： 数据库事务处理 ConnManage(Conn_object)
 '21： 快速排序（递归） QuickSort(arr,Low,High)
 '22： 将数组的元素以特定字符串连起来 arr_join(arr,character)
 '23： 返回字符串以某分割符分割的数目 count_character(str,character)
 '24： 截取含有分割符的字符串中指定数目的字符串 inter_str_by_character_num(str,character,start,num)
 '25： 利用Stream下载文件 downloadFile(strFile)
 '26： 返回信息 send_back(ResultWords)
 '27： 获取错误信息 get_err()
 '28： 与SafeRequest相反 SafeResponse(content)
 '29： 保存远程图片 SaveRemoteFile(LocalFileName,RemoteFileUrl)
 '30： ...
dim language_arr(10)
 language_arr(0) = "数据库连接的参数设置错误！"
language_arr(1) = "数据库连接的类型参数设置错误！"
language_arr(2) = "数据库连接失败！"
language_arr(3) = "非法的参数值！"
language_arr(4) = "参数值不是有效的日期格式！"
language_arr(5) = "操作失败！"
language_arr(6) = "栏目有重名！"
language_arr(7) = "栏目名称为空！"
language_arr(8) = "栏目文件夹创建失败！"
language_arr(9) = "您没有此权限！"
 '
 '函数ID：1
 '函数作用：建立数据库的连接
'修改时间：
'传人参数：
' connectStr：数据库连接字符串
' connectType：数据库类别-数字型，0为Access,1为MS SQL
 '返回值：
'
 
sub ConnOpen(DataBaseConnectStr,DBType,Conn_object)
 Set Conn_object = Server.Createobject("adodb.connection")
 if DataBaseConnectStr = "" then call ShowErr(language_arr(0))
 if DBType = 0 then
 Conn_object.Open "driver={Microsoft Access Driver (*.mdb)};dbq=" & DataBaseConnectStr
 elseif DBType = 1 then
 Conn_object.Open "Provider=SQLOLEDB.1;" & DataBaseConnectStr
 else
 call ShowErr(language_arr(1))
 end if
 err.clear
 end sub
 '
 
'函数ID：2
 '函数作用：断开数据库的连接
'修改时间：
'传人参数：
'返回值：
'
 
Sub ConnClose(Conn_object)
 Conn_object.close
 set Conn_object = nothing
 End sub
 '
 
'函数ID：3
 '函数作用：防止SQL注入
'修改时间：
'传人参数：
' paraName:参数名称-字符型
' paraType:参数类型-数字型(1表示以上参数是数字，0表示以上参数为字符)
'返回值：
' 过滤后的字符串
'
 
Function SafeRequest(paraName,paraType)
 dim paraValue
 paraValue = Request(paraName)
 select case paraType
 case 0
 paraValue = replace(paraValue,"'","[system:34]")
 paraValue = replace(paraValue,"=","[system:61]")
 case 1
 if not IsNumeric(paraValue) then call ShowErr(language_arr(3))
 case -1
 if not IsNumeric(paraValue) then call ShowErr(language_arr(3))
 if paraValue = "" then paraValue = 0
 case else
 if len(paraValue) > paraType then call ShowErr(language_arr(3))
 paraValue = replace(paraValue,"'","[system:34]")
 paraValue = replace(paraValue,"=","[system:61]")
 end select
 SafeRequest = paraValue
 End function
 '==============================='函数ID：4
 '函数作用：格式化日期
'修改时间：
'传人参数：
' dateStr:日期字符串
' paraType:日期类型-数字型
'返回值：
' 格式化后的日期
Function DateFormat(dateStr,dateType)
 Dim dateString
 if IsDate(dateStr) = False then
 call ShowErr(language_arr(4))
 end if
 Select Case dateType
 Case "1"
 dateString = Year(dateStr)&"-"&Month(dateStr)&"-"&Day(dateStr)
 Case "2"
 dateString = Year(dateStr)&"."&Month(dateStr)&"."&Day(dateStr)
 Case "3"
 dateString = Year(dateStr)&"/"&Month(dateStr)&"/"&Day(dateStr)
 Case "4"
 dateString = Month(dateStr)&"/"&Day(dateStr)&"/"&Year(dateStr)
 Case "5"
 dateString = Day(dateStr)&"/"&Month(dateStr)&"/"&Year(dateStr)
 Case "6"
 dateString = Month(dateStr)&"-"&Day(dateStr)&"-"&Year(dateStr)
 Case "7"
 dateString = Month(dateStr)&"."&Day(dateStr)&"."&Year(dateStr)
 Case "8"
 dateString = Month(dateStr)&"-"&Day(dateStr)
 Case "9"
 dateString = Month(dateStr)&"/"&Day(dateStr)
 Case "10"
 dateString = Month(dateStr)&"."&Day(dateStr)
 Case "11"
 dateString = Month(dateStr)&language_arr(6)&Day(dateStr)&language_arr(7)
 Case "12"
 dateString = Day(dateStr)&language_arr(7)&Hour(dateStr)&language_arr(8)
 case "13"
 dateString = Day(dateStr)&language_arr(7)&Hour(dateStr)&language_arr(8)
 Case "14"
 dateString = Hour(dateStr)&language_arr(8)&Minute(dateStr)&language_arr(9)
 Case "15"
 dateString = Hour(dateStr)&":"&Minute(dateStr)
 Case "16"
 dateString = Year(dateStr)&language_arr(5)&Month(dateStr)&language_arr(6)&Day(dateStr)&language_arr(7)
 Case Else
 dateString = dateStr
 End Select
 DateFormat = dateString
 End Function
 '
 '函数ID：5
 '函数作用：显示错误提示
'修改时间：
'传人参数：
 
' errStr:错误提示-字符型
'返回值：返回提交页面
'
 
sub ShowErr(errStr)
 Response.Write("
<script>alert("""&errStr&""");location.href=""javascript:history.back()"";</script>
")
 Response.End
 End sub
 '
'函数ID：6
 '函数作用：查询字符串中特定数据
'修改时间：
'传人参数：
' contentStr:查询字符串
' patternStr:匹配式字符串
' patternNum:查询定位-数字型
'返回值：
' 找不到返回false
 ' patternNum为-1返回所有匹配字符串并以[10]隔开
' 否则返回指定位置的字符串
'
 
Function SelectStr(contentStr,patternStr,patternNum)
 dim objRegExp,matches,matche
 if contentStr = "" then
 call ShowErr(language_arr(12))
 end if
 Set objRegExp=new RegExp '建立正则表达式
objRegExp.pattern = patternStr '设置模式
objRegExp.IgnoreCase =False '设置是否区分字符大小写
objRegExp.Global=true '设置全局可用性
objRegExp.pattern = patternStr '匹配式
 
if objRegExp.test(contentStr) = false then '全局匹配
SelectStr = false
 else
 Set matches = objRegExp.Execute(contentStr) '执行搜索
if patternNum = -1 then
 for each matche in matches
 SelectStr = SelectStr &"[10]"& matche.value
 next
 else
 SelectStr = matches.Item(patternNum).value
 end if
 end if
 
Set objRegExp=Nothing
 End Function
 '
 
'函数ID：7
 '函数作用：过滤指定字符
'修改时间：
'传人参数：
' contentStr:源字符串
' badWords:要过滤的字符串，若数目大于1则用英文状态的"^"隔开
'返回值：
' 返回过滤后的字符串
'
 
Function Leach(contentStr,badWords)
 dim badWordsArr,i
 badWordsArr = Split(badWords,"^")
 for i = 0 to UBound(badWordsArr)
 contentStr = replace(contentStr,badWordsArr(i),"")
 next
 leach = contentStr
 end Function
 ''函数ID：8
 '函数作用：远程文件内容抓取
'修改时间：
'传人参数：
' urlStr:远程文件地址
'返回值：
' 返回远程文件内容
'function Seize(urlStr)
 dim connect
 if urlStr = "" then
 call ShowErr(language_arr(13))
 else
 Set connect = CreateObject("Microsoft.XMLHTTP") '建立XMLHTTP对象
connect.open "GET",urlStr,false '设置参数，通信方式为get，请求为同步，后面还有两个可选属性：userID，password用于用户验证
connect.send() '数据发送，Send方法的参数类型可以是字符串、DOM树或任意数据流
Seize = BytesToBStr(connect.responseBody,"GB2312") '返回信息，编码为中文
set connect = nothing
 end if
 end function
 ''函数ID：9
 '函数作用：数据流编码处理
'修改时间：
'传人参数：
' body:数据内容
' cset:编码格式
'返回值：
' 编码处理后的信息
Function BytesToBstr(body,cset)
 dim objstream
 set objstream = Server.CreateObject("adodb.stream")
 objstream.Type = 1 '以二进制模式打开
objstream.Mode =3
 objstream.Open
 objstream.Write body
 objstream.Position = 0
 objstream.Type = 2
 objstream.Charset = cset
 BytesToBstr = objstream.ReadText
 objstream.Close
 set objstream = nothing
 End Function
 '函数ID：10
 '函数作用：编码cookies
 '修改时间：
'传人参数：
' contentStr:数据内容
'返回值：
' 编码处理后的信息，字符以"a"隔开
Function codeCookie(contentStr)
 Dim i,returnStr
 For i = Len(contentStr) to 1 Step -1
 returnStr = returnStr & Ascw(Mid(contentStr,i,1))
 If (i <> 1) Then returnStr = returnStr & "a"
 Next
 CodeCookie = returnStr
 End Function
 ''函数ID：11
 '函数作用：解码cookies
 '修改时间：
'传人参数：
' contentStr:数据内容
'返回值：
' 解码处理后的信息
'Function DecodeCookie(contentStr)
 Dim i
 Dim StrArr,StrRtn
 StrArr = Split(contentStr,"a")
 For i = 0 to UBound(StrArr)
 If isNumeric(StrArr(i)) = True Then
 StrRtn = Chrw(StrArr(i)) & StrRtn
 Else
 StrRtn = contentStr
 Exit Function
 End If
 Next
 DecodeCookie = StrRtn
 End Function
 ''函数ID：12
 '函数作用：检验数据提交来源是否合法
'修改时间：
'传人参数：
'
 '返回值：
' Boolean
 'Function ChkPost()
 Dim server_v1,server_v2
 Chkpost=False
 server_v1=Cstr(Request.ServerVariables("HTTP_REFERER"))
 server_v2=Cstr(Request.ServerVariables("SERVER_NAME"))
 If Mid(server_v1,8,len(server_v2))=server_v2 Then Chkpost=True
 End Function
 '函数ID：13
 '函数作用：个性化加密
'修改时间：
'传人参数：
' StrPassword：需加密的数据
'返回值：
' 加密后的数据
'Function MyEncrypt(StrPassword)
 Dim StrLen,StrLeft,StrRight,n
 n = 8
 StrPassword = MD5(StrPassword)
 StrLen = len(StrPassword)
 StrLeft = left(StrPassword,n)
 StrRight = right(StrPassword,StrLen-n)
 MyEncrypt = StrRight&StrLeft
 End function
 '函数ID：14
 '函数作用：禁止浏览器缓存本页
'修改时间：
'传人参数：
'返回值：
'

Sub NoBuffer()
 Response.expires = 0
 Response.expiresabsolute = Now() - 1
 Response.addHeader "pragma","no-cache"
 Response.addHeader "cache-control","private"
 Response.CacheControl = "no-cache"
 end sub
 '函数ID：15
 '函数作用：网页格式化输入文本
'修改时间：
'传人参数：
' fString：源字符串
'返回值：格式化后的字符串
function HTMLEncode(fString)
 if not isnull(fString) then
 fString = replace(fString, ">", ">")
 fString = replace(fString, "<", "<")
 fString = Replace(fString, CHR(32)&CHR(32), " ")
 fString = Replace(fString, CHR(9), " ")
 fString = Replace(fString, CHR(34), """)
 fString = Replace(fString, CHR(39), "'")
 fString = Replace(fString, CHR(13), "")
 fString = Replace(fString, CHR(10) & CHR(10), "</p><p>")
 fString = Replace(fString, CHR(10), "
")
 HTMLEncode = fString
 end if
 end function
 ''函数ID：16
 '函数作用：从头部截取字符串的指定长度(按字符数算)
 '修改时间：
'传人参数：
' Str：源字符串
' StrLen：长度
'返回值：截取得到的字符串
'Function GotTopic(Str,StrLen)
 Dim l,t,c, i,LableStr,regEx,Match,Matches,focus,last_str
 if IsNull(Str) then
 GotTopic = ""
 Exit Function
 end if
 if Str = "" then
 GotTopic=""
 Exit Function
 end if
 Set regEx = New RegExp
 regEx.Pattern = "[[^[]]*]"
 regEx.IgnoreCase = True
 regEx.Global = True
 Set Matches = regEx.Execute(Str)
 For Each Match in Matches
 LableStr = LableStr & Match.Value
 Next
 Str = regEx.Replace(Str,"")
 Str=Replace(Replace(Replace(Replace(Str," "," "),""",Chr(34)),">",">"),"<","<")
 l=len(str)
 t=0
 strlen=Clng(strLen)
 for i=1 to l
 c=Abs(Asc(Mid(str,i,1)))
 if c>255 then
 t=t+2
 else
 t=t+1
 end if
 if t = strLen-2 then
 focus = i
 last_str = ".."
 end if
 if t = strLen-1 then
 focus = i
 last_str = "."
 end if
 if t>=strlen then
 GotTopic=left(str,focus)&last_str
 exit for
 else
 GotTopic=str
 end if
 next
 GotTopic = Replace(Replace(Replace(Replace(GotTopic," "," "),Chr(34),"""),">",">"),"<","<") & LableStr
 end function
 '
 '函数ID：17
 '函数作用：检测验证码
'修改时间：
'传人参数：
' RadomPass：输入的验证码
'返回值：
'
Sub CheckRadomPass(RadomPass)
 if radompass = "" then
 call ShowErr(language_arr(14))
 elseif Session("GetCode") = "9999" then
 Session("GetCode")=""
 elseif Session("GetCode") = "" then
 call ShowErr(language_arr(15))
 elseif cstr(Session("GetCode"))<>radompass then
 call ShowErr(language_arr(16))
 end if
 Session("GetCode")=""
 End sub
 '
 '函数ID：18
 '函数作用：生成验证码
'修改时间：
'传人参数：
'返回值：
'
Function GetCode()
 Dim TestObj
 On Error Resume Next
 Set TestObj = Server.CreateObject("Adodb.Stream")
 Set TestObj = Nothing
 If Err Then
 Dim TempNum
 Randomize timer
 TempNum = cint(8999*Rnd+1000)
 Session("GetCode") = TempNum
 GetCode = Session("GetCode")
 Else
 GetCode = "<img src="""&Site_Url&"inc/GetCode.asp"">"
 End If
 End Function
 '
 '函数ID：19
 '函数作用：获取客户端操作系统版本
'修改时间：
'传人参数：
'返回值：操作系统版本名称
'
Function GetSystem()
 dim System
 System = Request.ServerVariables("HTTP_USER_AGENT")
 if Instr(System,"Windows NT 5.2") then
 System = "Win2003"
 elseif Instr(System,"Windows NT 5.0") then
 System="Win2000"
 elseif Instr(System,"Windows NT 5.1") then
 System = "WinXP"
 elseif Instr(System,"Windows NT") then
 System = "WinNT"
 elseif Instr(System,"Windows 9") then
 System = "Win9x"
 elseif Instr(System,"unix") or instr(System,"linux") or instr(System,"SunOS") or instr(System,"BSD") then
 System = "Unix"
 elseif Instr(System,"Mac") then
 System = "Mac"
 else
 System = "Other"
 end if
 GetSystem = System
 End Function
 '
 '函数ID：20
 '函数作用：数据库事务处理
'修改时间：
'传人参数：
'返回值：true or false
 '
 function ConnManage(Conn_object)
 if Conn_object.Errors.count<>0 then
 Conn_object.rollbacktrans
 err.clear
 ConnManage = false
 else
 Conn_object.committrans
 ConnManage = true
 end if
 end function
 '
 '函数ID：21
 '函数作用：快速排序（递归）
'修改时间：
'传人参数：
' arr:需排序的数组
' Low:数组最小下标
' High:数组最大下标
'返回值：
'
Sub QuickSort(arr,Low,High)
 Dim i,j,x,y,k
 i=Low
 j=High
 x=arr(Cint((Low+High)/2))
 Do
 While (arr(i)-x<0 and i<High)
 i=i+1
 Wend
 While (x-arr(j)<0 and="" j="">Low)
 j=j-1
 Wend
 If i<=j Then
 y=arr(i)
 arr(i)=arr(j)
 

arr(j)=y
 i=i+1
 j=j-1
 End if
 Loop while i<=j
 If Low<j Then call QuickSort(arr,Low,j)
 If i<High Then call QuickSort(arr,i,High)
 End sub
 '
 '函数ID：22
 '函数作用：将数组的元素以特定字符串连起来
'修改时间：
'传人参数：
' arr:需串连的数组
' character:串连字符
'返回值：
' 串连后的字符串
'
function arr_join(arr,character)
 dim i
 for i = 0 to ubound(arr)
 if i = 0 then
 arr_join = arr(i)
 else
 arr_join = arr_join & character & arr(i)
 end if
 next
 end function
 '
 '函数ID：23
 '函数作用：返回字符串以某分割符分割的数目
'修改时间：
'传人参数：
' errStr:错误提示-字符型
'返回值：返回提交页面
'
function count_character(str,character)
 dim i
 i = 0
 Do Until InStr(str,character) = 0
 str = Mid(str, InStr(str,character) + 1)
 i = i + 1
 Loop
 count_character = i
 End function
 '
 '函数ID：24
 '函数作用：截取含有分割符的字符串中指定数目的字符串
'修改时间：
'传人参数：
' errStr:错误提示-字符型
'返回值：返回提交页面
'
function inter_str_by_character_num(str,character,start,num)
 dim i,str_temp,start_location,inter_length,str_length
 i = 0
 inter_length = 0
 str_length = len(str)
 str = right(left(str,str_length-1),str_length-2)
 str_length = str_length - 2
 str_temp = str
 Do Until InStr(str_temp,character) = 0
 i = i + 1
 str_temp = Mid(str_temp,InStr(str_temp,character) + 1)
 if i = start - 1 then start_location = str_length - len(str_temp)
 if i = start + num - 1 then
 inter_length = str_length - len(str_temp) - start_location
 exit do
 end if
 Loop
 if inter_length = 0 then
 inter_str_by_character_num = mid(str,start_location+1)
 else
 inter_str_by_character_num = mid(str,start_location+1,inter_length-1)
 end if
 End function
 '
 '函数ID：25
 '函数作用：利用Stream下载文件
'修改时间：
'传人参数：
' errStr:错误提示-字符型
'返回值：返回提交页面
'
function downloadFile(strFile)
 dim strFilename,s,fso,f,intFilelength
 Response.Buffer = True
 Response.Clear
 Set s = Server.CreateObject("ADODB.Stream")
 s.Open
 s.Type = 1
 on error resume next
 Set fso = Server.CreateObject("Scripting.FileSystemObject")
 if not fso.FileExists(strFile) then
 Response.Write("<h1>Error:</h1>该文件不存在<p>")
 Response.End
 end if
 Set f = fso.GetFile(strFile)
 intFilelength = f.size
 
s.LoadFromFile(strFile)
 if err then
 Response.Write("<h1>Error:</h1>文件下载错误<p>")
 Response.End
 end if
 Response.AddHeader "Content-Disposition","attachment;filename=" & f.name
 Response.AddHeader "Content-Length",intFilelength
 Response.CharSet = "UTF-8"
 Response.ContentType = "application/octet-stream"
 Response.BinaryWrite s.Read
 Response.Flush
 s.Close
 set f = nothing
 set fso = nothing
 Set s = Nothing
 end function
 '
 '函数ID：26
 '函数作用：返回信息
'修改时间：
'传人参数：
'返回值：
'
sub send_back(ResultWords)
 dim objResult
 Set objResult = Server.CreateObject("MSXML2.DOMDocument")
 objResult.loadXML ("<返回结果></返回结果>")
objResult.selectSingleNode("返回结果").text = ResultWords
 Response.ContentType = "text/xml"
 objResult.save (Response)
 Response.End
 Set objResult = Nothing
 end sub
 '
 '函数ID：27
 '函数作用：获取错误信息www.atcpu.com
'修改时间：
'传人参数：
'返回值：
'
function get_err()
 if Err.Number > 0 then
 get_err = Err.Description
 else
 get_err = "T"
 end if
 end function
 '
 '函数ID：28
 '函数作用：与SafeRequest相反
'修改时间：
'传人参数：
' paraName:参数名称-字符型
' paraType:参数类型-数字型(1表示以上参数是数字，0表示以上参数为字符)
'返回值：
' 过滤后的字符串
'
function SafeResponse(content)
 dim paraValue
 paraValue = content
 paraValue = replace(paraValue,"[system:34]","'")
 paraValue = replace(paraValue,"[system:61]","=")
 SafeResponse = paraValue
 end function
 '
 '函数ID：29
 '函数作用：保存远程图片
'修改时间：
'传人参数：
' LocalFileName:本地文件名
' RemoteFileUrl:远程文件URL
 '返回值：
'
sub SaveRemoteFile(LocalFileName,RemoteFileUrl)
 dim Ads,Retrieval,GetRemoteData
 Set Retrieval = Server.CreateObject("Microsoft.XMLHTTP")
 With Retrieval
 .Open "Get", RemoteFileUrl, False, "", ""
 .Send
 GetRemoteData = .ResponseBody
 End With
 Set Retrieval = Nothing
 Set Ads = Server.CreateObject("Adodb.Stream")
 With Ads
 .Type = 1
 .Open
 .Write GetRemoteData
 .SaveToFile LocalFileName,2
 .Cancel()
 .Close()
 End With
 Set Ads=nothing
 end sub
 %>