一个ASP函数库

<%
'******************************
'类名：
'名称：通用库
'日期：2008/10/28
'作者：by xilou
'网址：
'描述：通用库
'版权：转载请注名出处，作者
'******************************
'最后修改：
'修改次数：
'修改说明：
'目前版本：
'******************************/

'输出
Sub Echo(str)
Response.Write str
End Sub

'断点
Sub Halt()
Response.End()
End Sub

'输出并换行
Sub Br(str)
Echo str & "<br />" & vbcrlf
End Sub

'简化Request.Form()
'f : 表单名称
Function P(f)
P = Replace(Request.Form(f), Chr(0), "")
End Function

'接收表单并替换单引号
Function Pr(f)
Pr = Replace(Request.Form(f), Chr(0), "")
Pr = Replace(Pr, "'", "''")
End Function

'简化Request.Querystring()
'f : 表单名称
Function G(f)
G = Replace(Request.QueryString(f), Chr(0), "")
End Function

'接收url参数并替换单引号
Function Gr(f)
Gr = Replace(Request.QueryString(f), Chr(0), "")
Gr = Replace(Gr, "'", "''")
End Function

'//构造()?:三目运算 by xilou www.chinacms.org
'ifThen为true返回s1,为false返回s2
Function IfThen(ifTrue, s1, s2)
Dim t
If ifTrue Then
t = s1
Else
t = s2
End If
IfThen = t
End Function

'显示不同颜色的是和否
Function IfThenFont(ifTrue, s1, s2)
Dim str
If ifTrue Then
str = "<font color=""#006600"">" & s1 & "</font>"
Else
str = "<font color=""#FF0000"">" & s2 & "</font>"
End If
IfThenFont = str
End Function

'创建Dictionary对象
Function HashTable()
Set HashTable = Server.CreateObj("Scripting.Dictionary")
HashTable.CompareMode = 1
End Function

'创建XmlHttp
Function XmlHttp()
Set XmlHttp = Server.createobject("MSXML2.XMLHTTP")
End Function

'创建XmlDom
Function XmlDom()
End Function

'创建AdoStream
Function AdoStream()
Set AdoStream = Server.CreateObject("Adodb.Stream")
End Function

'创建一个1维数组
'返回n个元素的空数组
'n : 元素个数
Function NewArray(n)
Dim ary : ary = array()
ReDim ary(n-1)
NewArray = ary
End Function

'构造Try..Catch
Sub Try()
On Error Resume Next
End Sub

'构造Try..Catch
Sub Catch(msg)
Dim html
html = "<ul><li>$1</li></ul>"
If Err Then
If msg <> "" Then
echo Replace(html, "$1", msg)
Halt
Else
echo Replace(html, "$1", Err.Description)
Halt
End If
Err.Clear
Response.End()
End If
End Sub

'--------------------------------数组操作开始
'判断数组中是否存在某个值
Function InArray(arr, s)
If VarType(arr) <> 8192 Then InArray = False : Exit Function
Dim i
For i = LBound(arr) To UBound(arr)
If s = arr(i) Then InArray = True : Exit Function
Next
InArray = False
End Function

'用ary数组中的值分别替换str中的占位符
'返回替换后的字符串
'str:要替换的字符串,占位符分别为$0,$1,$2...
'ary:用来替换的数组,每个值分别对应占位符中的$0,$1,$2...
'如:ReplaceByAry("$0-$1-$2 $3:$4:$5",Array(y,m,d,h,i,s))
Function ReplaceByAry(str,ary)
Dim i, j, L1, L2 : j = 0
If IsArray(ary) Then
L1 = LBound(ary) : L2 = UBound(ary)
For i = L1 To L2
str = Replace(str, "$"&j, ary(i))
j = j+1
Next
End If
ReplaceByAry = str
End Function
'--------------------------------数组操作结束

'--------------------------------随机数操作开始
'获取随机数
'm-n的随机数字
Function RndNumber(m,n)
Randomize
RndNumber = Int((n - m + 1) * Rnd + m)
End Function

'获取随机字符串
'n : 产生的长度
Function RndText(n)
Dim str1, str2, i, x, L
str1 = "NOPQRSTUVWXYZ012ABCDEFGHIJKLM3456abcdefghijklm789nopqrstuvwxyz"
L = Len(str1)
Randomize
For i = 1 To n
x = Int((L - 1 + 1) * Rnd + 1)
str2 = str2 & Mid(str1,x,1)
Next
RndText = str2
End Function

'从字符串str中产生m至n个的随机字符串
'如果str为空则默认从数字和字母中产生随机字符串
'str : 要从该字符串中产生随机字符串
'm,n : 产生n到m位
Function RndByText(str, m, n)
Dim i, k, str2, L, x
If str = "" Then str = "NOPQRSTUVWXYZ012ABCDEFGHIJKLM3456abcdefghijklm789nopqrstuvwxyz"
L = Len(str)
If n = m Then
k = n
Else
Randomize
k = Int((n - m + 1) * Rnd + m)
End If
Randomize
For i = 1 To k
x = Int((L - 1 + 1) * Rnd + 1)
str2 = str2 & Mid(str, x, 1)
Next
RndByText = str2
End Function

'日期时间组成随机数
'返回当前时间的数字组合
Function RndByDateTime()
Dim dt : dt = Now()
RndByDateTime = Year(dt) & Month(dt) & Day(dt) & Hour(dt) & Minute(dt) & Second(dt)
End Function
'--------------------------------随机数操作结束

'--------------------------------字符串操作开始
'判断一字符串str2在另一个字符串str1中出现的次数
'返回次数，没有则返回0
'str1 :接受搜索的字符串表达式
'str2 :要搜索的字符串表达式
'start:要搜索的开始位置,为空表示默认从1开始搜索
Function InStrTimes(str1, str2, start)
Dim a,c
If start = "" Then start = 1
c = 0
a = InStr(start, str1, str2)
Do While a > 0
c = c + 1
a = InStr(a+1, str1, str2)
Loop
InStrTimes = c
End Function

'字符串连接
'无返回
'strResult : 连接后保存的字符
'str : 要连接的字符
'partition : 连接字符间的分割符号
Sub JoinStr(byref strResult,str,partition)
If strResult <> "" Then
strResult = strResult & partition & str
Else
strResult = str
End If
End Sub

'计算字符串的字节长度，一个汉字=2字节
Function StrLen(str)
If isNull(str) or Str = "" Then
StrLen = 0
Exit Function
End If
Dim WINNT_CHINESE
WINNT_CHINESE = (len("例子")=2)
If WINNT_CHINESE Then
Dim l,t,c
Dim i
l = len(str)
t = l
For i = 1 To l
c = asc(mid(str,i,1))
If c<0 Then c = c + 65536
If c>255 Then t = t + 1
Next
StrLen = t
Else
StrLen = len(str)
End If
End Function

'截取字符串
' str : 要截取的字符串
' strlen : 要截取的长度
' addStr : 超过长度的用这个代替，如:...
Function CutStr(str, strlen, addStr)
Dim l, t, c
'str=str&""
If Is_Empty(str) Then CutStr = "" : Exit Function
If str="" or IsEmpty(str) Then CutStr="" : Exit Function
'On Error Resume Next
l = len(str) : t = 0
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 Then
CutStr = left(str, i) & addStr
Exit For
Else
CutStr = str
End If
Next
'If Err Then Err.Clear:CutStr=Left(str,strlen)
End Function

'全角转换成半角
Function SBCcaseConvert(str)
Dim b, c, i
b = "１,２,３,４,５,６,７,８,９,０," _
&"Ａ,Ｂ,Ｃ,Ｄ,Ｅ,Ｆ,Ｇ,Ｈ,Ｉ,Ｊ,Ｋ,Ｌ,Ｍ,Ｎ,Ｏ,Ｐ,Ｑ,Ｒ,Ｓ,Ｔ,Ｕ,Ｖ,Ｗ,Ｘ,Ｙ,Ｚ"
c = "1,2,3,4,5,6,7,8,9,0," _
&"A,B,C,D,E,F,G,H,I,J,K,L,M,N,O,P,Q,R,S,T,U,V,W,X,Y,Z"
b = split(b,",")
c = split(c,",")
For i = 0 To Ubound(b)
If instr(str,b(i)) > 0 Then
str = Replace(str, b(i), c(i))
End If
Next
SBCcaseConvert = str
End Function

'与javascript中的escape()等效
Function VbsEscape(str)
dim i,s,c,a
s=""
For i=1 to Len(str)
c = Mid(str,i,1)
a = ASCW(c)
If (a>=48 and a<=57) or (a>=65 and a<=90) or (a>=97 and a<=122) Then
s = s & c
ElseIf InStr("@*_+-./",c) > 0 Then
s = s & c
ElseIf a>0 and a<16 Then
s = s & "%0" & Hex(a)
ElseIf a>=16 and a<256 Then
s = s & "%" & Hex(a)
Else
s = s & "%u" & Hex(a)
End If
Next
VbsEscape = s
End Function

'对javascript中使用escape()编码过的数据进行解码,ajax调用时用
Function VbsUnEscape(str)
Dim x
x=InStr(str,"%")
Do While x > 0
VbsUnEscape = VbsUnEscape & Mid(str,1,x-1)
If LCase(Mid(str,x+1,1)) = "u" Then
VbsUnEscape = VbsUnEscape&ChrW(CLng("&H"&Mid(str,x+2,4)))
str = Mid(str,x+6)
Else
VbsUnEscape = VbsUnEscape&Chr(CLng("&H"&Mid(str,x+1,2)))
str = Mid(str,x+3)
End If
x = InStr(str,"%")
Loop
VbsUnEscape = VbsUnEscape&str
End Function
'--------------------------------字符串操作结束

'--------------------------------时间日期操作开始
'根据年份和月份获得相应的月份天数
'返回天数
'y : 年份,如：2008
'm : 月份,如：3
Function GetDayCount(y,m)
Dim c
Select Case m
Case 1, 3, 5, 7, 8, 10, 12
c=31
Case 2
If IsDate(y&"-"&m&"-"&"29") Then
c = 29
Else
c = 28
End If
Case Else
c = 30
End Select
GetDayCount = c
End Function

'判断一个日期时间是否在某段时间之间,包括比较的两头时间
Function IsBetweenTime(fromTime,toTime,strTime)
If DateDiff("s",fromTime,strTime) >= 0 And DateDiff("s",toTime,strTime) <= 0 Then
IsBetweenTime = True
Else
IsBetweenTime = False
End If
End Function
'--------------------------------时间日期操作结束

'--------------------------------安全加密相关操作开始
'加密串,要使用MD5()函数
Function iEncrypt()
Dim ary(3),i,str,str1,str2,n,s,s1,s2
For i = 0 To 3
ary(i) = RndText(5)
str = str&Asc(mid(ary(i),2,1))
Next

str1 = ary(0)&ary(2)
str2 = ary(1)&ary(3)
For i = 1 To Len(str1) - 1
s1 = Asc(mid(str1,i,1))
s2 = Asc(mid(str2,i,1))
n = s1 Xor s2
s = s & chr(n)
Next
iEncrypt = Join(ary,",")&","&MD5(s&EncryptKey&str)
End Function

'验证加密串的正确性
'返回 True | False
'str : 要验证的字符串,8qp2b,ruZwh,kICkU,xzM1B,174d5e97ebb8e163
Function iValidate(strText)
Dim ary,i,L,str,str1,str2,n,s,s1,s2,oldText
If strText = "" Then iValidate = False : Exit Function
ary = Split(strText,",")
L = UBound(ary)
If L <> 4 Then iValidate = False : Exit Function
For i = 0 To 3
str = str&Asc(mid(ary(i),2,1))
Next
str1 = ary(0)&ary(2)
str2 = ary(1)&ary(3)
For i = 1 To Len(str1) - 1
s1 = Asc(mid(str1,i,1))
s2 = Asc(mid(str2,i,1))
n = s1 Xor s2
s = s & chr(n)
Next
oldText = MD5(s&EncryptKey&str)
If oldText = ary(4) Then
iValidate = True
Else
iValidate = False
End If
End Function
'--------------------------------安全加密相关操作结束

'--------------------------------数据合法性验证操作开始
'--------------------------------数据合法性验证操作结束

'--------------------------------文件操作开始
'获取文件后缀，如jpg
Function GetFileExt(f)
GetFileExt = Lcase(Mid(f,InStrRev(f,".") + 1))
End Function
'--------------------------------文件操作结束

'--------------------------------其他操作开始
'显示信息
'message : 要显示的信息
'url : 要跳转的URL
'typeNum : 显示方式，1弹出信息，回退到上一页；2弹出信息，转到url处
Sub ShowMsg(message,url,typeNum)
message = replace(message,"'","\'")
Select Case TypeNum
Case 1
echo ("<script language=javascript>alert('" & message & "');history.go(-1)</script>")
Case 2
echo ("<script language=javascript>alert('" & message & "');location='" & Url &"'</script>")
End Select
End Sub

'显示option列表并定位,by xilou www.chinacms.org
'textArr : 文本数组
'valueArr : 值数组
'curValue : 当前选定值
Function ShowOpList(textArr, valueArr, curValue)
Dim str, style, i
style = "style=""background-color:#FFCCCC"""
str = ""
If IsNull(curValue) Then curValue = ""
For I = LBound(textArr) To UBound(valueArr)
If Cstr(valueArr(I)) = Cstr(curValue) Then
str = str&"<option value="""&valueArr(I)&""" selected=""selected"" "&style&" >"&textArr(I)&"</option>"&vbcrlf
Else
str = str&"<option value="""&valueArr(I)&""" >"&textArr(I)&"</option>"&vbcrlf
End If
Next
ShowOpList = str
End Function

'多选列表
'注意:要使用到InArray()函数
'textArr : 文本数组
'valueArr : 值数组
'curValue : 当前选定值数组
Function ShowMultiOpList(textArr,valueArr,curValueArr)
Dim style, str, isCurr, I
style = "style=""background-color:#FFCCCC"""
str = "" : isCurr = False
If IsNull(curValue) Then curValue = ""
For I = LBound(textArr) To UBound(valueArr)
If InArray(curValueArr, valueArr(I)) Then
str = str&"<option value="""&valueArr(I)&""" selected=""selected"" "&style&" >"&textArr(I)&"</option>"&vbcrlf
Else
str = str&"<option value="""&valueArr(I)&""" >"&textArr(I)&"</option>"&vbcrlf
End If
Next
ShowMultiOpList = str
End Function
'--------------------------------其他操作结束
%>