ASP的一些自定义函数整理

  <%

  '============================================================================================================================

  '函数列表:

  '1:    建立数据库的连接 ConnOpen(DataBaseConnectStr,DBType,Conn_object)

  '2:    断开数据库的连接 ConnClose(Conn_object)

  '3:    防止SQL注入 SafeRequest(paraName,paraType)

  '4:    格式化日期 DateFormat(dateStr,dateType)

  '5:    显示错误提示 ShowErr(errStr)

  '6:    查询字符串中特定数据 SelectStr(contentStr,patternStr,patternNum)

  '7:    过滤指定字符 Leach(contentStr,badWords)

  '8:    远程文件内容抓取 Seize(urlStr)

  '9:    数据流编码处理 BytesToBstr(body,cset)

  '10:    编码cookies codeCookie(contentStr)

  '11:    解码cookies DecodeCookie(contentStr)

  '12:    检验数据提交来源是否合法 ChkPost()

  '13:    个性化加密 MyEncrypt(StrPassword)

  '14:    禁止浏览器缓存本页 NoBuffer()

  '15:    网页格式化输入文本 HTMLEncode(fString)

  '16:    从头部截取字符串的指定长度(按字符数算) GotTopic(Str,StrLen)

  '17:    检测验证码 CheckRadomPass(RadomPass)

  '18:    生成验证码 GetCode()

  '19:    获取客户端操作系统版本 GetSystem()

  '20:    数据库事务处理 ConnManage(Conn_object)

  '21:    快速排序(递归) QuickSort(arr,Low,High)

  '22:    将数组的元素以特定字符串连起来 arr_join(arr,character)

  '23:    返回字符串以某分割符分割的数目 count_character(str,character)

  '24:    截取含有分割符的字符串中指定数目的字符串 inter_str_by_character_num(str,character,start,num)

  '25:    利用Stream下载文件 downloadFile(strFile)

  '26:    返回信息 send_back(ResultWords)

  '27:    获取错误信息 get_err()

  '28:    与SafeRequest相反 SafeResponse(content)

  '29:    保存远程图片 SaveRemoteFile(LocalFileName,RemoteFileUrl)

  '30:    ...

  dim language_arr(10)

  language_arr(0) = "数据库连接的参数设置错误!"

  language_arr(1) = "数据库连接的类型参数设置错误!"

  language_arr(2) = "数据库连接失败!"

  language_arr(3) = "非法的参数值!"

  language_arr(4) = "参数值不是有效的日期格式!"

  language_arr(5) = "操作失败!"

  language_arr(6) = "栏目有重名!"

  language_arr(7) = "栏目名称为空!"

  language_arr(8) = "栏目文件夹创建失败!"

  language_arr(9) = "您没有此权限!"

  '============================================================================================================================

  '函数ID:1

  '函数作用:建立数据库的连接

  '作者名称:茫仔 [email protected] 博客:blog.mzoe.com

  '建立时间:2006-2-15 10:28

  '修改时间:

  '传人参数:

  '    connectStr:数据库连接字符串

  '    connectType:数据库类别-数字型,0为Access,1为MS SQL

  '返回值:

  '============================================================================================================================

  sub ConnOpen(DataBaseConnectStr,DBType,Conn_object)

  Set Conn_object = Server.Createobject("adodb.connection")

  if DataBaseConnectStr = "" then call ShowErr(language_arr(0))

  if DBType = 0 then

  Conn_object.Open "driver={Microsoft Access Driver (*.mdb)};dbq=" & DataBaseConnectStr

  elseif DBType = 1 then

  Conn_object.Open "Provider=SQLOLEDB.1;" & DataBaseConnectStr

  else

  call ShowErr(language_arr(1))

  end if

  err.clear

  end sub

  '============================================================================================================================

  '函数ID:2

  '函数作用:断开数据库的连接

  '作者名称:茫仔 [email protected] 博客:blog.mzoe.com

  '建立时间:2006-2-16 15:10

  '修改时间:

  '传人参数:

  '返回值:

  '============================================================================================================================

  Sub ConnClose(Conn_object)

  Conn_object.close

  set Conn_object = nothing

  End sub

  '============================================================================================================================

  '函数ID:3

  '函数作用:防止SQL注入

  '作者名称:http://news.dvbbs.net/infoview/Article_2906.html

  '建立时间:2006-2-16 15:32

  '修改时间:

  '传人参数:

  '    paraName:参数名称-字符型

  '    paraType:参数类型-数字型(1表示以上参数是数字,0表示以上参数为字符) 

  '返回值:

  '    过滤后的字符串

  '============================================================================================================================

  Function SafeRequest(paraName,paraType)

  dim paraValue

  paraValue = Request(paraName)

  select case paraType

  case 0

  paraValue = replace(paraValue,"'","[system:34]")

  paraValue = replace(paraValue,"=","[system:61]")

  case 1

  if not IsNumeric(paraValue) then call ShowErr(language_arr(3))

  case -1

  if not IsNumeric(paraValue) then call ShowErr(language_arr(3))

  if paraValue = "" then paraValue = 0

  case else

  if len(paraValue) > paraType then call ShowErr(language_arr(3))

  paraValue = replace(paraValue,"'","[system:34]")

  paraValue = replace(paraValue,"=","[system:61]")

  end select

  SafeRequest = paraValue

  End function

  '============================================================================================================================

  '函数ID:4

  '函数作用:格式化日期

  '作者名称:茫仔 [email protected] 博客:blog.mzoe.com

  '建立时间:2006-2-16 15:45

  '修改时间:

  '传人参数:

  '    dateStr:日期字符串

  '    paraType:日期类型-数字型

  '返回值:

  '    格式化后的日期

  '============================================================================================================================

  Function  DateFormat(dateStr,dateType)

  Dim dateString

  if IsDate(dateStr) = False then

  call ShowErr(language_arr(4))

  end if

  Select Case dateType

  Case "1"

  dateString = Year(dateStr)&"-"&Month(dateStr)&"-"&Day(dateStr)

  Case "2"

  dateString = Year(dateStr)&"."&Month(dateStr)&"."&Day(dateStr)

  Case "3"

  dateString = Year(dateStr)&"/"&Month(dateStr)&"/"&Day(dateStr)

  Case "4"

  dateString = Month(dateStr)&"/"&Day(dateStr)&"/"&Year(dateStr)

  Case "5"

  dateString = Day(dateStr)&"/"&Month(dateStr)&"/"&Year(dateStr)

  Case "6"

  dateString = Month(dateStr)&"-"&Day(dateStr)&"-"&Year(dateStr)

  Case "7"

  dateString = Month(dateStr)&"."&Day(dateStr)&"."&Year(dateStr)

  Case "8"

  dateString = Month(dateStr)&"-"&Day(dateStr)

  Case "9"

  dateString = Month(dateStr)&"/"&Day(dateStr)

  Case "10"

  dateString = Month(dateStr)&"."&Day(dateStr)

  Case "11"

  dateString = Month(dateStr)&language_arr(6)&Day(dateStr)&language_arr(7)

  Case "12"

  dateString = Day(dateStr)&language_arr(7)&Hour(dateStr)&language_arr(8)

  case "13"

  dateString = Day(dateStr)&language_arr(7)&Hour(dateStr)&language_arr(8)

  Case "14"

  dateString = Hour(dateStr)&language_arr(8)&Minute(dateStr)&language_arr(9)

  Case "15"

  dateString = Hour(dateStr)&":"&Minute(dateStr)

  Case "16"

  dateString = Year(dateStr)&language_arr(5)&Month(dateStr)&language_arr(6)&Day(dateStr)&language_arr(7)

  Case Else

  dateString = dateStr

  End Select

  DateFormat = dateString

  End Function

  '============================================================================================================================

  '函数ID:5

  '函数作用:显示错误提示

  '作者名称:茫仔 [email protected] 博客:blog.mzoe.com

  '建立时间:2006-2-16 16:29

  '修改时间:

  '传人参数:

  '    errStr:错误提示-字符型

  '返回值:返回提交页面

  '============================================================================================================================

  sub ShowErr(errStr)

  Response.Write("<script>alert("""&errStr&""");location.href=""javascript:history.back()"";</script>")

  Response.End

  End sub

  '============================================================================================================================

  '函数ID:6

  '函数作用:查询字符串中特定数据

  '作者名称:茫仔 [email protected] 博客:blog.mzoe.com

  '建立时间:2006-2-16 16:40

  '修改时间:

  '传人参数:

  '    contentStr:查询字符串

  '    patternStr:匹配式字符串

  '    patternNum:查询定位-数字型

  '返回值:

  '    找不到返回false

  '    patternNum为-1返回所有匹配字符串并以[10]隔开

  '    否则返回指定位置的字符串

  '============================================================================================================================

  Function SelectStr(contentStr,patternStr,patternNum)

  dim objRegExp,matches,matche

  if contentStr = "" then

  call ShowErr(language_arr(12))

  end if

  Set objRegExp=new RegExp   '建立正则表达式

  objRegExp.pattern = patternStr    '设置模式

  objRegExp.IgnoreCase =False    '设置是否区分字符大小写

  objRegExp.Global=true    '设置全局可用性

  objRegExp.pattern = patternStr    '匹配式

  if objRegExp.test(contentStr) = false then    '全局匹配

  SelectStr = false

  else

  Set matches = objRegExp.Execute(contentStr)    '执行搜索

  if patternNum = -1 then

  for each matche in matches

  SelectStr = SelectStr &"[10]"& matche.value

  next

  else

  SelectStr = matches.Item(patternNum).value

  end if

  end if

  Set objRegExp=Nothing

  End Function

  '============================================================================================================================

  '函数ID:7

  '函数作用:过滤指定字符

  '作者名称:茫仔 [email protected] 博客:blog.mzoe.com

  '建立时间:2006-2-16 16:59

  '修改时间:

  '传人参数:

  '    contentStr:源字符串

  '    badWords:要过滤的字符串,若数目大于1则用英文状态的"^"隔开

  '返回值:

  '    返回过滤后的字符串

  '============================================================================================================================

  Function Leach(contentStr,badWords)

  dim badWordsArr,i

  badWordsArr = Split(badWords,"^")

  for i = 0 to UBound(badWordsArr)

  contentStr = replace(contentStr,badWordsArr(i),"")

  next

  leach = contentStr

  end Function

  '============================================================================================================================

  '函数ID:8

  '函数作用:远程文件内容抓取

  '作者名称:茫仔 [email protected] 博客:blog.mzoe.com

  '建立时间:2006-2-16 17:24

  '修改时间:

  '传人参数:

  '    urlStr:远程文件地址

  '返回值:

  '    返回远程文件内容

  '============================================================================================================================

  function Seize(urlStr)

  dim connect

  if urlStr = "" then

  call ShowErr(language_arr(13))

  else

  Set connect = CreateObject("Microsoft.XMLHTTP")    '建立XMLHTTP对象

  connect.open "GET",urlStr,false    '设置参数,通信方式为get,请求为同步,后面还有两个可选属性:userID,password用于用户验证

  connect.send()     '数据发送,Send方法的参数类型可以是字符串、DOM树或任意数据流

  Seize = BytesToBStr(connect.responseBody,"GB2312")    '返回信息,编码为中文

  set connect = nothing

  end if

  end function

  '============================================================================================================================

  '函数ID:9

  '函数作用:数据流编码处理

  '作者名称:茫仔 [email protected] 博客:blog.mzoe.com

  '建立时间:2006-2-16 17:30

  '修改时间:

  '传人参数:

  '    body:数据内容

  '    cset:编码格式

  '返回值:

  '    编码处理后的信息

  '============================================================================================================================

  Function BytesToBstr(body,cset)

  dim objstream

  set objstream = Server.CreateObject("adodb.stream")

  objstream.Type = 1    '以二进制模式打开

  objstream.Mode =3

  objstream.Open

  objstream.Write body

  objstream.Position = 0

  objstream.Type = 2

  objstream.Charset = cset

  BytesToBstr = objstream.ReadText

  objstream.Close

  set objstream = nothing

  End Function

  '============================================================================================================================

  '函数ID:10

  '函数作用:编码cookies

  '作者名称:茫仔 [email protected] 博客:blog.mzoe.com

  '建立时间:2006-2-16 17:36

  '修改时间:

  '传人参数:

  '    contentStr:数据内容

  '返回值:

  '    编码处理后的信息,字符以"a"隔开

  '============================================================================================================================

  Function codeCookie(contentStr)

  Dim i,returnStr

  For i = Len(contentStr) to 1 Step -1

  returnStr = returnStr & Ascw(Mid(contentStr,i,1))

  If (i <> 1) Then returnStr = returnStr & "a"

  Next

  CodeCookie = returnStr

  End Function

  '============================================================================================================================

  '函数ID:11

  '函数作用:解码cookies

  '作者名称:茫仔 [email protected] 博客:blog.mzoe.com

  '建立时间:2006-2-17 16:58

  '修改时间:

  '传人参数:

  '    contentStr:数据内容

  '返回值:

  '    解码处理后的信息

  '============================================================================================================================

  Function DecodeCookie(contentStr)

  Dim i

  Dim StrArr,StrRtn

  StrArr = Split(contentStr,"a")

  For i = 0 to UBound(StrArr)

  If isNumeric(StrArr(i)) = True Then

  StrRtn = Chrw(StrArr(i)) & StrRtn

  Else

  StrRtn = contentStr

  Exit Function

  End If

  Next

  DecodeCookie = StrRtn

  End Function

  '============================================================================================================================

  '函数ID:12

  '函数作用:检验数据提交来源是否合法

  '作者名称:茫仔 [email protected] 博客:blog.mzoe.com

  '建立时间:2006-2-18 18:55

  '修改时间:

  '传人参数:

  '

  '返回值:

  '    Boolean

  '============================================================================================================================

  Function ChkPost()

  Dim server_v1,server_v2

  Chkpost=False

  server_v1=Cstr(Request.ServerVariables("HTTP_REFERER"))

  server_v2=Cstr(Request.ServerVariables("SERVER_NAME"))

  If Mid(server_v1,8,len(server_v2))=server_v2 Then Chkpost=True

  End Function

  '============================================================================================================================

  '函数ID:13

  '函数作用:个性化加密

  '作者名称:茫仔 [email protected] 博客:blog.mzoe.com

  '建立时间:2006-2-25 15:12

  '修改时间:

  '传人参数:

  '    StrPassword:需加密的数据

  '返回值:

  '    加密后的数据

  '============================================================================================================================

  Function  MyEncrypt(StrPassword)

  Dim StrLen,StrLeft,StrRight,n

  n = 8

  StrPassword = MD5(StrPassword)

  StrLen = len(StrPassword)

  StrLeft = left(StrPassword,n)

  StrRight = right(StrPassword,StrLen-n)

  MyEncrypt = StrRight&StrLeft

  End function

  '============================================================================================================================

  '函数ID:14

  '函数作用:禁止浏览器缓存本页

  '作者名称:茫仔 [email protected] 博客:blog.mzoe.com

  '建立时间:2006-3-5 2:45

  '修改时间:

  '传人参数:

  '返回值:

  '============================================================================================================================

  Sub NoBuffer()

  Response.expires = 0

  Response.expiresabsolute = Now() - 1

  Response.addHeader "pragma","no-cache"

  Response.addHeader "cache-control","private"

  Response.CacheControl = "no-cache"

  end sub

  '============================================================================================================================

  '函数ID:15

  '函数作用:网页格式化输入文本

  '作者名称:茫仔 [email protected] 博客:blog.mzoe.com

  '建立时间:2006-3-5 2:50

  '修改时间:

  '传人参数:

  '     fString:源字符串

  '返回值:格式化后的字符串

  '============================================================================================================================

  function HTMLEncode(fString)

  if not isnull(fString) then

  fString = replace(fString, ">", ">")

  fString = replace(fString, "<", "<")

  fString = Replace(fString, CHR(32)&CHR(32), "  ")

  fString = Replace(fString, CHR(9), " ")

  fString = Replace(fString, CHR(34), """)

  fString = Replace(fString, CHR(39), "'")

  fString = Replace(fString, CHR(13), "")

  fString = Replace(fString, CHR(10) & CHR(10), "</P><P>")

  fString = Replace(fString, CHR(10), "<BR>")

  HTMLEncode = fString

  end if

  end function

  '============================================================================================================================

  '函数ID:16

  '函数作用:从头部截取字符串的指定长度(按字符数算)

  '作者名称:茫仔 [email protected] 博客:blog.mzoe.com

  '建立时间:2006-3-5 3:04

  '修改时间:

  '传人参数:

  '     Str:源字符串

  '    StrLen:长度

  '返回值:截取得到的字符串

  '============================================================================================================================

  Function GotTopic(Str,StrLen)

  Dim l,t,c, i,LableStr,regEx,Match,Matches,focus,last_str

  if IsNull(Str) then

  GotTopic = ""

  Exit Function

  end if

  if Str = "" then

  GotTopic=""

  Exit Function

  end if

  Set regEx = New RegExp

  regEx.Pattern = "\[[^\[\]]*\]"

  regEx.IgnoreCase = True

  regEx.Global = True

  Set Matches = regEx.Execute(Str)

  For Each Match in Matches

  LableStr = LableStr & Match.Value

  Next

  Str = regEx.Replace(Str,"")

  Str=Replace(Replace(Replace(Replace(Str," "," "),""",Chr(34)),">",">"),"<","<")

  l=len(str)

  t=0

  strlen=Clng(strLen)

  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-2 then

  focus = i

  last_str = ".."

  end if

  if t = strLen-1 then

  focus = i

  last_str = "."

  end if

  if t>=strlen then

  GotTopic=left(str,focus)&last_str

  exit for

  else

  GotTopic=str

  end if

  next

  GotTopic = Replace(Replace(Replace(Replace(GotTopic," "," "),Chr(34),"""),">",">"),"<","<") & LableStr

  end function

  '============================================================================================================================

  '函数ID:17

  '函数作用:检测验证码

  '作者名称:茫仔 [email protected] 博客:blog.mzoe.com

  '建立时间:2006-3-5 3:09

  '修改时间:

  '传人参数:

  '     RadomPass:输入的验证码

  '返回值:

  '============================================================================================================================

  Sub CheckRadomPass(RadomPass)

  if radompass = "" then

  call ShowErr(language_arr(14))

  elseif Session("GetCode") = "9999" then

  Session("GetCode")=""

  elseif Session("GetCode") = "" then

  call ShowErr(language_arr(15))

  elseif cstr(Session("GetCode"))<>radompass then

  call ShowErr(language_arr(16))

  end if

  Session("GetCode")=""

  End sub

  '============================================================================================================================

  '函数ID:18

  '函数作用:生成验证码

  '作者名称:茫仔 [email protected] 博客:blog.mzoe.com

  '建立时间:2006-3-5 3:16

  '修改时间:

  '传人参数:

  '返回值:

  '============================================================================================================================

  Function GetCode()

  Dim TestObj

  On Error Resume Next

  Set TestObj = Server.CreateObject("Adodb.Stream")

  Set TestObj = Nothing

  If Err Then

  Dim TempNum

  Randomize timer

  TempNum = cint(8999*Rnd+1000)

  Session("GetCode") = TempNum

  GetCode = Session("GetCode")

  Else

  GetCode = "<img src="""&Site_Url&"inc/GetCode.asp"">"

  End If

  End Function

  '============================================================================================================================

  '函数ID:19

  '函数作用:获取客户端操作系统版本

  '作者名称:茫仔 [email protected] 博客:blog.mzoe.com

  '建立时间:2006-3-5 3:21

  '修改时间:

  '传人参数:

  '返回值:操作系统版本名称

  '============================================================================================================================

  Function GetSystem()

  dim System

  System = Request.ServerVariables("HTTP_USER_AGENT")

  if Instr(System,"Windows NT 5.2") then

  System = "Win2003"

  elseif Instr(System,"Windows NT 5.0") then

  System="Win2000"

  elseif Instr(System,"Windows NT 5.1") then

  System = "WinXP"

  elseif Instr(System,"Windows NT") then

  System = "WinNT"

  elseif Instr(System,"Windows 9") then

  System = "Win9x"

  elseif Instr(System,"unix") or instr(System,"linux") or instr(System,"SunOS") or instr(System,"BSD") then

  System = "Unix"

  elseif Instr(System,"Mac") then

  System = "Mac"

  else

  System = "Other"

  end if

  GetSystem = System

  End Function

  '============================================================================================================================

  '函数ID:20

  '函数作用:数据库事务处理

  '作者名称:茫仔 [email protected] 博客:blog.mzoe.com

  '建立时间:2006-3-5 3:25

  '修改时间:

  '传人参数:

  '返回值:true or false

  '============================================================================================================================

  function ConnManage(Conn_object)

  if Conn_object.Errors.count<>0 then

  Conn_object.rollbacktrans

  err.clear

  ConnManage = false

  else

  Conn_object.committrans

  ConnManage = true

  end if

  end function

  '============================================================================================================================

  '函数ID:21

  '函数作用:快速排序(递归)

  '作者名称:茫仔 [email protected] 博客:blog.mzoe.com

  '建立时间:2006-4-9 19:53

  '修改时间:

  '传人参数:

  '    arr:需排序的数组

  '    Low:数组最小下标

  '    High:数组最大下标

  '返回值:

  '============================================================================================================================

  Sub QuickSort(arr,Low,High)

  Dim i,j,x,y,k

  i=Low

  j=High

  x=arr(Cint((Low+High)/2))

  Do

  While (arr(i)-x<0 and i<High)

  i=i+1

  Wend

  While (x-arr(j)<0 and j>Low)

  j=j-1

  Wend

  If i<=j Then

  y=arr(i)

  arr(i)=arr(j)

  arr(j)=y

  i=i+1

  j=j-1

  End if

  Loop while i<=j

  If Low<j Then call QuickSort(arr,Low,j)

  If i<High Then call QuickSort(arr,i,High)

  End sub

  '============================================================================================================================

  '函数ID:22

  '函数作用:将数组的元素以特定字符串连起来

  '作者名称:茫仔 [email protected] 博客:blog.mzoe.com

  '建立时间:2006-4-9 21:16

  '修改时间:

  '传人参数:

  '    arr:需串连的数组

  '    character:串连字符

  '返回值:

  '    串连后的字符串

  '============================================================================================================================

  function arr_join(arr,character)

  dim i

  for i = 0 to ubound(arr)

  if i = 0 then

  arr_join = arr(i)

  else

  arr_join = arr_join & character & arr(i)

  end if

  next

  end function

  '============================================================================================================================

  '函数ID:23

  '函数作用:返回字符串以某分割符分割的数目

  '作者名称:茫仔 [email protected] 博客:blog.mzoe.com

  '建立时间:2006-2-16 16:29

  '修改时间:

  '传人参数:

  '    errStr:错误提示-字符型

  '返回值:返回提交页面

  '============================================================================================================================

  function count_character(str,character)

  dim i

  i = 0

  Do Until InStr(str,character) = 0

  str = Mid(str, InStr(str,character) + 1)

  i = i + 1

  Loop

  count_character = i

  End function

  '============================================================================================================================

  '函数ID:24

  '函数作用:截取含有分割符的字符串中指定数目的字符串

  '作者名称:茫仔 [email protected] 博客:blog.mzoe.com

  '建立时间:2006-2-16 16:29

  '修改时间:

  '传人参数:

  '    errStr:错误提示-字符型

  '返回值:返回提交页面

  '============================================================================================================================

  function inter_str_by_character_num(str,character,start,num)

  dim i,str_temp,start_location,inter_length,str_length

  i = 0

  inter_length = 0

  str_length = len(str)

  str = right(left(str,str_length-1),str_length-2)

  str_length = str_length - 2

  str_temp = str

  Do Until InStr(str_temp,character) = 0

  i = i + 1

  str_temp = Mid(str_temp,InStr(str_temp,character) + 1)

  if i = start - 1 then start_location = str_length - len(str_temp)

  if i = start + num - 1 then

  inter_length = str_length - len(str_temp) - start_location

  exit do

  end if

  Loop

  if inter_length = 0 then

  inter_str_by_character_num = mid(str,start_location+1)

  else

  inter_str_by_character_num = mid(str,start_location+1,inter_length-1)

  end if

  End function

  '============================================================================================================================

  '函数ID:25

  '函数作用:利用Stream下载文件

  '作者名称:茫仔 [email protected] 博客:blog.mzoe.com

  '建立时间:2006-2-16 16:29

  '修改时间:

  '传人参数:

  '    errStr:错误提示-字符型

  '返回值:返回提交页面

  '============================================================================================================================

  function downloadFile(strFile)

  dim strFilename,s,fso,f,intFilelength

  Response.Buffer = True

  Response.Clear

  Set s = Server.CreateObject("ADODB.Stream")

  s.Open

  s.Type = 1

  on error resume next

  Set fso = Server.CreateObject("Scripting.FileSystemObject")

  if not fso.FileExists(strFile)  then

  Response.Write("<h1>Error:</h1>该文件不存在<p>")

  Response.End

  end if

  Set f = fso.GetFile(strFile)

  intFilelength = f.size

  s.LoadFromFile(strFile)

  if err then

  Response.Write("<h1>Error:</h1>文件下载错误<p>")

  Response.End

  end  if

  Response.AddHeader "Content-Disposition","attachment;filename=" & f.name

  Response.AddHeader "Content-Length",intFilelength

  Response.CharSet = "UTF-8"

  Response.ContentType = "application/octet-stream"

  Response.BinaryWrite s.Read

  Response.Flush

  s.Close

  set f = nothing

  set fso = nothing

  Set s = Nothing

  end function

  '============================================================================================================================

  '函数ID:26

  '函数作用:返回信息

  '作者名称:茫仔 [email protected] 博客:blog.mzoe.com

  '建立时间:2006-2-21 20:45

  '修改时间:

  '传人参数:

  '返回值:

  '============================================================================================================================

  sub send_back(ResultWords)

  dim objResult

  Set objResult = Server.CreateObject("MSXML2.DOMDocument")

  objResult.loadXML ("<返回结果></返回结果>")

  objResult.selectSingleNode("返回结果").text = ResultWords

  Response.ContentType = "text/xml"

  objResult.save (Response)

  Response.End

  Set objResult = Nothing

  end sub

  '============================================================================================================================

  '函数ID:27

  '函数作用:获取错误信息

  '作者名称:茫仔 [email protected] 博客:blog.mzoe.com

  '建立时间:2006-4-22 13:13

  '修改时间:

  '传人参数:

  '返回值:

  '============================================================================================================================

  function get_err()

  if Err.Number > 0 then

  get_err = Err.Description

  else

  get_err = "T"

  end if

  end function

  '============================================================================================================================

  '函数ID:28

  '函数作用:与SafeRequest相反

  '作者名称:茫仔 [email protected] 博客:blog.mzoe.com

  '建立时间:2006-2-16 15:32

  '修改时间:

  '传人参数:

  '    paraName:参数名称-字符型

  '    paraType:参数类型-数字型(1表示以上参数是数字,0表示以上参数为字符) 

  '返回值:

  '    过滤后的字符串

  '============================================================================================================================

  function SafeResponse(content)

  dim paraValue

  paraValue = content

  paraValue = replace(paraValue,"[system:34]","'")

  paraValue = replace(paraValue,"[system:61]","=")

  SafeResponse = paraValue

  end function

  '============================================================================================================================

  '函数ID:29

  '函数作用:保存远程图片

  '作者名称:http://news.dvbbs.net/infoview/Article_2906.html

  '建立时间:2006-2-16 15:32

  '修改时间:

  '传人参数:

  '    LocalFileName:本地文件名

  '   RemoteFileUrl:远程文件URL

  '返回值:

  '============================================================================================================================

  sub SaveRemoteFile(LocalFileName,RemoteFileUrl)

  dim Ads,Retrieval,GetRemoteData

  Set Retrieval = Server.CreateObject("Microsoft.XMLHTTP")

  With Retrieval

  .Open "Get", RemoteFileUrl, False, "", ""

  .Send

  GetRemoteData = .ResponseBody

  End With

  Set Retrieval = Nothing

  Set Ads = Server.CreateObject("Adodb.Stream")

  With Ads

  .Type = 1

  .Open

  .Write GetRemoteData

  .SaveToFile LocalFileName,2

  .Cancel()

  .Close()

  End With

  Set Ads=nothing

  end sub

  %>