program code
<%
'******************************
'Class name:
'Name: general library
'Date: 2008/10/28
'Author: by xilou
'Website: http://www.chinacms.org
'Description: General library
'Copyright: Please indicate the source and author when reprinting
'******************************
'Last modified: 20090108
'Number of modifications: 2
'Modification description:
'20090108 Add the following functions:
' A2U(),U2A(),UrlEncode(),UrlDecode(),GBToUTF8(),Bytes2Str(),Str2Bytes()
'20090108 Add the following functions:
'AryToVbsString(arr)
'Current version:
'******************************/
'Output
Sub Echo(str)
Response.Write str
End Sub
'Breakpoint
Sub Halt()
Response.End()
End Sub
'Output and wrap
SubBr(str)
Echo str & "<br />" & vbcrlf
End Sub
'Simplify Request.Form()
'f : form name
Function P(f)
P = Replace(Request.Form(f), Chr(0), "")
End Function
'Receive the form and replace single quotes
Function Pr(f)
Pr = Replace(Request.Form(f), Chr(0), "")
Pr = Replace(Pr, "'", "''")
End Function
'Simplify Request.Querystring()
'f : form name
FunctionG(f)
G = Replace(Request.QueryString(f), Chr(0), "")
End Function
'Receive url parameters and replace single quotes
FunctionGr(f)
Gr = Replace(Request.QueryString(f), Chr(0), "")
Gr = Replace(Gr, "'", "''")
End Function
'//Construction()?:Ternary operation by xilou www.chinacms.org
'ifThen returns s1 for true and s2 for false
Function IfThen(ifTrue, s1, s2)
Dim t
If ifTrue Then
t = s1
Else
t = s2
End If
IfThen = t
End Function
'Display yes and no in different colors
Function IfThenFont(ifTrue, s1, s2)
Dimstr
If ifTrue Then
str = "<font color=""#006600"">" & s1 & "</font>"
Else
str = "<font color=""#FF0000"">" & s2 & "</font>"
End If
IfThenFont = str
End Function
'Create Dictionary object
Function NewHashTable()
Set NewHashTable = Server.CreateObj("Scripting.Dictionary")
NewHashTable.CompareMode = 1 'Key values are not case sensitive
End Function
'Create XmlHttp
Function NewXmlHttp()
Set NewXmlHttp = Server.createobject("MSXML2.XMLHTTP")
End Function
'Create XmlDom
Function NewXmlDom()
End Function
'Create AdoStream
Function NewAdoStream()
Set NewAdoStream = Server.CreateObject("Adodb.Stream")
End Function
'Create a 1-dimensional array
'Return an empty array of n elements
'n: number of elements
FunctionNewArray(n)
Dim ary : ary = array()
ReDim ary(n-1)
NewArray = ary
End Function
'Construct Try..Catch
SubTry()
On Error Resume Next
End Sub
'Construct Try..Catch
'msg: The error message thrown, if it is empty, Err.Description is thrown
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
'--------------------------------array operation begins
'Determine whether a certain value exists in the array
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
'Replace the placeholders in str with the values in the ary array.
'Return the replaced string
'str: The string to be replaced, the placeholders are $0, $1, $2...
'ary: Array used for replacement, each value corresponds to $0, $1, $2... in the placeholder.
'For example: 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
'-----------------------------array operation ends
'------------- ------------------Random number operation begins
'Get random numbers
'mn random number
Function RndNumber(m,n)
Randomize
RndNumber = Int((n - m + 1) * Rnd + m)
End Function
'Get a random string
'n : generated length
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
'Generate m to n random strings from the string str
'If str is empty, a random string will be generated from numbers and letters by default
'str : To generate a random string from this string
'm,n: generate n to m bits
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
'Date and time form random numbers
'Return the number combination of the current time
Function RndByDateTime()
Dim dt : dt = Now()
RndByDateTime = Year(dt) & Month(dt) & Day(dt) & Hour(dt) & Minute(dt) & Second(dt)
End Function
'-----------------------------Random number operation ends
'--------------------- --------------------String operation begins
'Determine the number of times a string str2 appears in another string str1
'Return the number of times, if not, return 0
'str1: string expression that accepts search
'str2: String expression to search for
'start: The starting position to be searched. If empty, it means starting from 1 by default.
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
'String concatenation
'No return
'strResult: Characters saved after connection
'str : character to be concatenated
'partition: separation symbol between connecting characters
Sub JoinStr(byref strResult,str,partition)
If strResult <> "" Then
strResult = strResult & partition & str
Else
strResult = str
End If
End Sub
'Calculate the byte length of the string, one Chinese character = 2 bytes
FunctionStrLen(str)
If isNull(str) or Str = "" Then
StrLen = 0
Exit Function
End If
Dim WINNT_CHINESE
WINNT_CHINESE = (len("example")=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
'Intercept string
'str: the string to be intercepted
'strlen: the length to be intercepted
' addStr: Use this instead if it exceeds the length, such as:...
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
'Convert full-width to half-width
Function SBCcaseConvert(str)
Dim b, c, i
b = "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, Ｙ,Ｚ"
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
'is equivalent to escape() in javascript
Function VbsEscape(str)
dimi,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
'Decode data encoded using escape() in javascript, used when calling 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
'Convert ascii characters to unicode encoding form
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
'Convert unicode encoding to ascii
'str: The string to be transcoded must all be unicode characters, otherwise an error will occur
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 encoding
Function UrlEncode(str)
UrlEncode = Server.UrlEncode(str)
End Function
'url decoding
FunctionUrlDecode(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 to UTF8--Convert GB encoded text to UTF8 encoded text
Function GBToUTF8(gbStr)
Dim wch,uch,szRet,szInput
Dim x
Dim nAsc, nAsc2, nAsc3
szInput = gbStr
'If the input parameter is empty, exit the function
If szInput = "" Then
toUTF8 = szInput
Exit Function
End If
'Start conversion
For x = 1 To Len(szInput)
'Use mid function to split GB encoded text
wch = Mid(szInput, x, 1)
'Use the ascW function to return the Unicode character code of each GB encoded text
'Note: the asc function returns ANSI character code, pay attention to the difference
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
'The Unicode character code of GB encoded text adopts a three-byte template between 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
'Conversion from Byte stream to Char stream
Function Bytes2Str(vin,charset)
Dim ms,strRet
Set ms = Server.CreateObject("ADODB.Stream") 'Create a stream object
ms.Type = 1 'Binary
ms.Open
ms.Write vin 'Write vin into the stream object
ms.Position = 0 'Set the starting position of the stream object to 0 to set the Charset property
ms.Type = 2 'Text
ms.Charset = charset 'Set the encoding mode of the stream object to charset
strRet = ms.ReadText 'Get the character stream
ms.close 'Close the stream object
Set ms = nothing
Bytes2Str = strRet
End Function
'Conversion of Char stream to Byte stream
Function Str2Bytes(str,charset)
Dim ms,strRet
Set ms = CreateObject("ADODB.Stream") 'Create a stream object
ms.Type = 2 'Text
ms.Charset = charset 'Set the encoding mode of the stream object to charset
ms.Open
ms.WriteText str 'Write str into the stream object
ms.Position = 0 'Set the starting position of the stream object to 0 to set the Charset property
ms.Type = 1 'Binary
vout = ms.Read(ms.Size) 'Get character stream
ms.close 'Close the stream object
Set ms = nothing
Str2Bytes = vout
End Function
'--------------------------------String operation ends
'--------------------- --------------------Time and date operation starts
'Get the corresponding number of days in the month based on the year and month
'Return the number of days
'y: year, such as: 2008
'm: month, such as: 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
'Determine whether a date and time is between a certain period of time, including the time at both ends of the comparison
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
'--------------------------------Time and date operation ends
'--------------------- --------------------Security encryption related operations begin
'-----------------------------Security encryption related operations end
'---------- ---------------------Data legality verification operation begins
'Detect string through regular expression and return 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
'Is it a positive integer?
FunctionIsPint(str)
IsPint = RegExpTest("^[1-9]{1}d*$", str)
End Function
'Whether it is 0 or a positive integer
FunctionIsInt(str)
IsInt = RegExpTest("^0|([1-9]{1}d*)$", str)
End Function
'Email
FunctionIsEmail(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
'cell phone
FunctionIsMobile(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
FunctionIsQQ(str)
Dim patrn
patrn = "^[1-9]d{4,8}$"
IsQQ = RegExpTest(patrn,str)
End Function
'ID card
FunctionIsIdCard(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 A
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
'postal code
Function IsZipCode(str)
Dim patrn
patrn = "^[1-9]d{2,5}$"
IsZipCode = RegExpTest(patrn,str)
End Function
'Whether it is empty, including the functions of 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
'--------------------------------Data validity verification operation ends
'--------- -----------------------File operation starts
'Get the file suffix, such as jpg
Function GetFileExt(f)
GetFileExt = Lcase(Mid(f,InStrRev(f,".") + 1))
End Function
'Generate folder
'path: the path to the folder to be generated, use a relative path
SubCFolder(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
'Delete folder
'path: folder path, use relative path
SubDFolder(path)
Dim fso
Set fso = Server.CreateObject("Scripting.FileSystemObject")
If fso.FolderExists(path) Then
fso.DeleteFolder path,true
Else
echo "Path does not exist:" & path
End If
Set fso = Nothing
End Sub
'Generate file
'path: Generate file path, including name
'strText: file content
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
'Delete file
'path: file path, including name
SubDFile(path)
Dim fso
Set fso = Server.CreateObject("Scripting.FileSystemObject")
If fso.FileExists(path) Then
Fso.DeleteFile(path)
End If
Set fso = Nothing
End Sub
'Collect
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
'Encoding conversion
Function BytesToBstr(body,Cset)
DimStreamObj
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
'--------------------------------File operation ends
'------------- ------------------Other operations begin
'Display information
'message: the message to be displayed
'url: URL to jump to
'typeNum: display mode, 1 pops up information and returns to the previous page; 2 pops up information and goes to the 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
'Display option list and position, by xilou www.chinacms.org
'textArr: text array
'valueArr: value array
'curValue: currently selected value
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
'Multiple selection list
'Note: You need to use the InArray() function
'textArr: text array
'valueArr: value array
'curValue: currently selected value array
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
'Convert the array into dictionary object storage
'hashObj: dictionary object
'ary: Array, the format must be one of the following two, the first can only store string values
' : array("Id:12","UserName:xilou","Sex:1"), that is, array("key:value",...) format
' : array(array("Id","12"),array("UserName","xilou"),array("Sex","1"))
'Return dictionary object
'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), the key value cannot be an object type,"
Response.Write "The current ary("& i &")(0) value type is:" & TypeName(ary(i)(0))
Response.End()
End If
If IsObject(ary(i)(1)) Then 'If the value is an object
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),"":""Does not exist"
Response.Write ",Occurs at:" & ary(i)
Response.End()
End If
If pos = 1 Then
Response.Write "Error:AryToHashTable(ary), key value does not exist"
Response.Write ",Occurs at:" & ary(i)
Response.End()
End If
k = Left(str,pos-1)
v = Mid(str,pos+1)
hashObj(k) = v
End If
Next
End Sub
'Convert the array into dictionary object storage
'ary: Array, the format must be one of the following two, the first can only store string values
' : array("Id:12","UserName:xilou","Sex:1"), that is, array("key:value",...) format
' : array(array("Id","12"),array("UserName","xilou"),array("Sex","1"))
'Return dictionary object
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
'Convert array to string, which is equivalent to serializing array. The only allowed formats are:
'array("p1:v1","p2:v2",array("p3",true))
'return string
Function AryToVbsString(arr)
Dim str,i,c
If Not IsArray(arr) Then Response.Write "Error: AryToString(arr) error, parameter arr is not an array"
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), the parameter contains illegal data, index i="&i&", the key value is: "&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
'--------------------------------Other operations end
%>