程式碼
<%
'******************************
'類別名稱：
'名稱：通用庫
'日期：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
為 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
'--------------------------------數組操作結束
'------------- -------------------隨機數字操作開始
'取得隨機數
'mn的隨機數字
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
為 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) 或 (a>=65 and a<=90) 或 (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") = "" 或 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
'--------------------------------其他動作結束
%>