程序代码
<%
'******************************
'类名：
'名称：通用库
'日期：2008/10/28
'作者：by xilou
'网址：http://www.chinacms.org
'描述：通用库
'版权：转载请注名出处，作者
'******************************
'最后修改：20090108
'修改次数：2
'修改说明：
'20090108 增加下列函数：
' A2U(),U2A(),UrlEncode(),UrlDecode(),GBToUTF8(),Bytes2Str(),Str2Bytes()
'20090108 增加下列函数：
' AryToVbsString(arr)
'目前版本：
'******************************/
'输出
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 NewHashTable()
Set NewHashTable = Server.CreateObj("Scripting.Dictionary")
NewHashTable.CompareMode = 1 '键值不区分大小写
End Function
'创建XmlHttp
Function NewXmlHttp()
Set NewXmlHttp = Server.createobject("MSXML2.XMLHTTP")
End Function
'创建XmlDom
Function NewXmlDom()
End Function
'创建AdoStream
Function NewAdoStream()
Set NewAdoStream = 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
'msg : 抛出的错误信息，如果为空则抛出Err.Description
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 Not IsArray(arr) 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 i,l, t, c
If Is_Empty(str) Then CutStr = "" : Exit Function
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
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
'将ascii字符转为unicode编码形式
Function A2U(str)
Dim i,L,uText
L = Len(str)
For i = 1 To L
uText = uText & "&#" & AscW(Mid(str,i,1)) & ";"
Next
A2U = uText
End Function
'将unicode编码转为ascii
'str : 要转码的字符串，必须全部都是unicode字符，否则会出错
Function U2A(str)
Dim ary,i,L,newStr
ary = Split(str,";")
L = UBound(ary)
For i = 0 To L - 1
newStr = newStr & ChrW(Replace(ary(i),"&#",""))
Next
U2A = newStr
End Function
'url编码
Function UrlEncode(str)
UrlEncode = Server.UrlEncode(str)
End Function
'url解码
Function UrlDecode(str)
Dim newstr, havechar, lastchar, i, char_c, next_1_c, next_1_Num
newstr = ""
havechar = false
lastchar = ""
For i = 1 To Len(str)
char_c = Mid(str,i,1)
If char_c = "+" Then
newstr = newstr & " "
ElseIf char_c = "%" Then
next_1_c = Mid(str, i+1, 2)
next_1_num = Cint("&H" & next_1_c)
If havechar Then
havechar = false
newstr = newstr & Chr(CInt("&H" & lastchar & next_1_c))
Else
If Abs(next_1_num) <= 127 Then
newstr = newstr & Chr(next_1_num)
Else
havechar = true
lastchar = next_1_c
End If
End If
i = i + 2
Else
newstr = newstr & char_c
End If
Next
UrlDecode = newstr
End Function
'GB转UTF8--将GB编码文字转换为UTF8编码文字
Function GBToUTF8(gbStr)
Dim wch, uch, szRet,szInput
Dim x
Dim nAsc, nAsc2, nAsc3
szInput = gbStr
'如果输入参数为空，则退出函数
If szInput = "" Then
toUTF8 = szInput
Exit Function
End If
'开始转换
For x = 1 To Len(szInput)
'利用mid函数分拆GB编码文字
wch = Mid(szInput, x, 1)
'利用ascW函数返回每一个GB编码文字的Unicode字符代码
'注：asc函数返回的是ANSI 字符代码，注意区别
nAsc = AscW(wch)
If nAsc < 0 Then nAsc = nAsc + 65536
If (nAsc And &HFF80) = 0 Then
szRet = szRet & wch
Else
If (nAsc And &HF000) = 0 Then
uch = "%" & Hex(((nAsc 2 ^ 6)) or &HC0) & Hex(nAsc And &H3F or &H80)
szRet = szRet & uch
Else
'GB编码文字的Unicode字符代码在0800 - FFFF之间采用三字节模版
uch = "%" & Hex((nAsc 2 ^ 12) or &HE0) & "%" & _
Hex((nAsc 2 ^ 6) And &H3F or &H80) & "%" & _
Hex(nAsc And &H3F or &H80)
szRet = szRet & uch
End If
End If
Next
GBToUTF8 = szRet
End Function
'Byte流到Char流的转换
Function Bytes2Str(vin,charset)
Dim ms,strRet
Set ms = Server.CreateObject("ADODB.Stream") '建立流对象
ms.Type = 1 ' Binary
ms.Open
ms.Write vin '把vin写入流对象中
ms.Position = 0 '设置流对象的起始位置是0 以设置Charset属性
ms.Type = 2 'Text
ms.Charset = charset '设置流对象的编码方式为 charset
strRet = ms.ReadText '取字符流
ms.close '关闭流对象
Set ms = nothing
Bytes2Str = strRet
End Function
'Char流到Byte流的转换
Function Str2Bytes(str,charset)
Dim ms,strRet
Set ms = CreateObject("ADODB.Stream") '建立流对象
ms.Type = 2 ' Text
ms.Charset = charset '设置流对象的编码方式为 charset
ms.Open
ms.WriteText str '把str写入流对象中
ms.Position = 0 '设置流对象的起始位置是0 以设置Charset属性
ms.Type = 1 'Binary
vout = ms.Read(ms.Size) '取字符流
ms.close '关闭流对象
Set ms = nothing
Str2Bytes = vout
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
'--------------------------------时间日期操作结束
'--------------------------------安全加密相关操作开始
'--------------------------------安全加密相关操作结束
'--------------------------------数据合法性验证操作开始
'通过正则检测字符串,返回true|false
Function RegExpTest(strPatrn,strText)
Dim objRegExp, matches
Set objRegExp = New RegExp
objRegExp.Pattern = strPatrn
objRegExp.IgnoreCase = False
objRegExp.Global = True
RegExpTest = objRegExp.Test(strText)
'Set matches = objRegExp.Execute(strText)
Set objRegExp = nothing
End Function
'是否是正整数
Function IsPint(str)
IsPint = RegExpTest("^[1-9]{1}d*$", str)
End Function
'是否是0或正整数
Function IsInt(str)
IsInt = RegExpTest("^0|([1-9]{1}d*)$", str)
End Function
'Email
Function IsEmail(str)
Dim patrn
patrn = "^w+((-w+)|(.w+))*@[A-Za-z0-9]+((.|-)[A-Za-z0-9]+)*.[A-Za-z0-9]+$"
IsEmail = RegExpTest(patrn,str)
End Function
'手机
Function IsMobile(str)
Dim patrn
patrn = "^(130|131|132|133|153|134|135|136|137|138|139|158|159){1}d{8}$"
IsMobile = RegExpTest(patrn,str)
End Function
'QQ
Function IsQQ(str)
Dim patrn
patrn = "^[1-9]d{4,8}$"
IsQQ = RegExpTest(patrn,str)
End Function
'身份证
Function IsIdCard(e)
Dim arrVerifyCode,Wi,Checker
arrVerifyCode = Split("1,0,x,9,8,7,6,5,4,3,2", ",")
Wi = Split("7,9,10,5,8,4,2,1,6,3,7,9,10,5,8,4,2", ",")
Checker = Split("1,9,8,7,6,5,4,3,2,1,1", ",")
If Len(e) < 15 or Len(e) = 16 or Len(e) = 17 or Len(e) > 18 Then
IsIdCard = False
Exit Function
End If
Dim Ai
If Len(e) = 18 Then
Ai = Mid(e, 1, 17)
ElseIf Len(e) = 15 Then
Ai = e
Ai = Left(Ai, 6) & "19" & Mid(Ai, 7, 9)
End If
If Not IsNumeric(Ai) Then
IsIdCard= False
Exit Function
End If
Dim strYear, strMonth, strDay, BirthDay
strYear = CInt(Mid(Ai, 7, 4))
strMonth = CInt(Mid(Ai, 11, 2))
strDay = CInt(Mid(Ai, 13, 2))
BirthDay = Trim(strYear) + "-" + Trim(strMonth) + "-" + Trim(strDay)
If IsDate(BirthDay) Then
If DateDiff("yyyy",Now,BirthDay)<-140 or cdate(BirthDay)>date() Then
IsIdCard= False
Exit Function
End If
If strMonth > 12 or strDay > 31 Then
IsIdCard= False
Exit Function
End If
Else
IsIdCard= False
Exit Function
End If
Dim i, TotalmulAiWi
For i = 0 To 16
TotalmulAiWi = TotalmulAiWi + CInt(Mid(Ai, i + 1, 1)) * Wi(i)
Next
Dim modValue
modValue = TotalmulAiWi Mod 11
Dim strVerifyCode
strVerifyCode = arrVerifyCode(modValue)
Ai = Ai & strVerifyCode
IsIdCard = Ai
If Len(e) = 18 And e <> Ai Then
IsIdCard= False
Exit Function
End If
IsIdCard=True
End Function
'邮政编码
Function IsZipCode(str)
Dim patrn
patrn = "^[1-9]d{2,5}$"
IsZipCode = RegExpTest(patrn,str)
End Function
'是否为空，包括IsEmpty(),IsNull(),""的功能
Function Is_Empty(str)
If IsNull(str) or IsEmpty(str) or str="" Then
Is_Empty=True
Else
Is_Empty=False
End If
End Function
'--------------------------------数据合法性验证操作结束
'--------------------------------文件操作开始
'获取文件后缀，如jpg
Function GetFileExt(f)
GetFileExt = Lcase(Mid(f,InStrRev(f,".") + 1))
End Function
'生成文件夹
'path : 要生成的文件夹路径，用相对路径
Sub CFolder(path)
Dim fso
Set fso = Server.CreateObject("Scripting.FileSystemObject")
If Not fso.FolderExists(path) Then
fso.CreateFolder(path)
End If
Set fso = Nothing
End Sub
'删除文件夹
'path : 文件夹路径，用相对路径
Sub DFolder(path)
Dim fso
Set fso = Server.CreateObject("Scripting.FileSystemObject")
If fso.FolderExists(path) Then
fso.DeleteFolder path,true
Else
echo "路径不存在:" & path
End If
Set fso = Nothing
End Sub
'生成文件
'path : 生成文件路径，包括名称
'strText: 文件内容
Sub CFile(path,strText)
Dim f,fso
Set fso = Server.CreateObject("Scripting.FileSystemObject")
Set f = fso.CreateTextFile(path)
f.Write strText
Set f = Nothing
Set fso = Nothing
End Sub
'删除文件
'path : 文件路径，包括名称
Sub DFile(path)
Dim fso
Set fso = Server.CreateObject("Scripting.FileSystemObject")
If fso.FileExists(path) Then
Fso.DeleteFile(path)
End If
Set fso = Nothing
End Sub
'采集
Function GetHTTPPage(url)
' Http.setTimeouts 10000,10000,10000,10000
'On Error Resume Next
Dim Http
Set Http = Server.createobject("MSXML2.XMLHTTP")
Http.open "GET",url,false
Http.send()
If Http.Status <> 200 Then
Exit Function
End If
'If Err Then Response.Write url : Response.End()
GetHTTPPage = bytesToBSTR(Http.ResponseBody,"GB2312")
'Http.Close()
'if err.number<>0 then err.Clear
End Function
'编码转换
Function BytesToBstr(body,Cset)
Dim StreamObj
Set StreamObj = Server.CreateObject("Adodb.Stream")
StreamObj.Type = 1
StreamObj.Mode = 3
StreamObj.Open
StreamObj.Write body
StreamObj.Position = 0
StreamObj.Type = 2
StreamObj.Charset = Cset
BytesToBstr = StreamObj.ReadText
StreamObj.Close
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
Function GetIP()
Dim strIPAddr,actforip
If Request.ServerVariables("HTTP_X_FORWARDED_FOR") = "" or InStr(Request.ServerVariables("HTTP_X_FORWARDED_FOR"), "unknown") > 0 Then
strIPAddr = Request.ServerVariables("REMOTE_ADDR")
ElseIf InStr(Request.ServerVariables("HTTP_X_FORWARDED_FOR"), ",") > 0 Then
strIPAddr = Mid(Request.ServerVariables("HTTP_X_FORWARDED_FOR"), 1, InStr(Request.ServerVariables("HTTP_X_FORWARDED_FOR"), ",")-1)
ElseIf InStr(Request.ServerVariables("HTTP_X_FORWARDED_FOR"), ";") > 0 Then
strIPAddr = Mid(Request.ServerVariables("HTTP_X_FORWARDED_FOR"), 1, InStr(Request.ServerVariables("HTTP_X_FORWARDED_FOR"), ";")-1)
Else
strIPAddr = Request.ServerVariables("HTTP_X_FORWARDED_FOR")
End If
GetIP = strIPAddr
End Function
'将数组转化为dictionary对象存储
'hashObj : dictionary对象
'ary : 数组，格式必须为以下两种之一,第一种只能存储字符串值
' : array("Id:12","UserName:xilou","Sex:1")，即array("key:value",...)格式
' : array(array("Id","12"),array("UserName","xilou"),array("Sex","1"))
'返回dictionary对象
'www.chinacms.org
Sub AryAddToHashTable(ByRef hashObj,ary)
Dim str,ht,i,k,v,pos
For i = 0 To UBound(ary)
If IsArray(ary(i)) Then
If IsObject(ary(i)(0)) Then
Response.Write "Error:AryToHashTable(ary),键值不可以是一个对象类型,"
Response.Write "当前ary("& i &")(0)值类型为:" & TypeName(ary(i)(0))
Response.End()
End If
If IsObject(ary(i)(1)) Then '如果值是一个对象
Set hashObj(ary(i)(0)) = ary(i)(1)
Else
hashObj(ary(i)(0)) = ary(i)(1)
End If
Else
str = ary(i) & ""
pos = InStr(str,":")
'www.chinacms.org
If pos < 1 Then
Response.Write "Error:AryToHashTable(ary),"":""不存在"
Response.Write ",发生在:" & ary(i)
Response.End()
End If
If pos = 1 Then
Response.Write "Error:AryToHashTable(ary),键值不存在"
Response.Write ",发生在:" & ary(i)
Response.End()
End If
k = Left(str,pos-1)
v = Mid(str,pos+1)
hashObj(k) = v
End If
Next
End Sub
'将数组转化为dictionary对象存储
'ary : 数组，格式必须为以下两种之一,第一种只能存储字符串值
' : array("Id:12","UserName:xilou","Sex:1")，即array("key:value",...)格式
' : array(array("Id","12"),array("UserName","xilou"),array("Sex","1"))
'返回dictionary对象
Function AryToHashTable(ary)
Dim str,ht,i,k,v,pos
Set ht = Server.CreateObject("Scripting.Dictionary")
ht.CompareMode = 1
AryAddToHashTable ht , ary
Set AryToHashTable = ht
End Function
'将array转为字符串,相当于序列化array，只可允许的格式为：
'array("p1:v1","p2:v2",array("p3",true))
'返回字符串
Function AryToVbsString(arr)
Dim str,i,c
If Not IsArray(arr) Then Response.Write "Error:AryToString(arr)错误,参数arr不是数组"
c = UBound(arr)
For i = 0 To c
If IsArray(arr(i)) Then
Select Case LCase(TypeName(arr(i)(1)))
Case "date","string","empty"
str = str & ",array(""" & arr(i)(0) & ""","""& arr(i)(1) &""")"
Case "integer","long","single","double","currency","decimal","boolean"
str = str & ",array(""" & arr(i)(0) & ""","& arr(i)(1) &")"
Case "null"
str = str & ",array(""" & arr(i)(0) & """,null)"
Case Else
Response.Write "Error:AryToVbsString(arr),参数包含非法数据,索引i="&i&",键值为:"&arr(i)(0)
Response.End()
End Select
Else
str = str & ",""" & arr(i) & """"
End If
Next
If str <> "" Then str = Mid(str, 2, Len(str) - 1)
str = "array(" & str & ")"
AryToVbsString = str
End Function
'--------------------------------其他操作结束
%>