ASP通用函数库

程序代码
<%
　  '******************************
　  '类名：
　  '名称：通用库
　  '日期：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
　  '--------------------------------其他操作结束
%>