一些小asp的函数

'*************************************
'获取客户端IP
'*************************************
function getIP() 
   dim strIP,IP_Ary,strIP_list
   strIP_list=Replace(Request.ServerVariables("HTTP_X_FORWARDED_FOR"),"'","") 
   If InStr(strIP_list,",")<>0 Then
   IP_Ary = Split(strIP_list,",")
   strIP = IP_Ary(0)
   Else
   strIP = strIP_list
   End IF
   If strIP=Empty Then strIP=Replace(Request.ServerVariables("REMOTE_ADDR"),"'","")
   getIP=strIP
End Function
'转换IP函数

'转换IP函数
function splitip(ip)
dim yl_ip
yl_ip=split(IP,".")
splitip=""&yl_ip(0)&"."&yl_ip(1)&"."&yl_ip(2)&".★"
end function

'*************************************
'获取客户端浏览器信息
'*************************************
function getBrowser(strUA) 
dim arrInfo,strType,temp1,temp2
strType=""
strUA=LCase(strUA)
arrInfo=Array("Unkown","Unkown")
'浏览器判断
if Instr(strUA,"mozilla")>0 then arrInfo(0)="Mozilla"
if Instr(strUA,"icab")>0 then arrInfo(0)="iCab"
if Instr(strUA,"lynx")>0 then arrInfo(0)="Lynx"
if Instr(strUA,"links")>0 then arrInfo(0)="Links"
if Instr(strUA,"elinks")>0 then arrInfo(0)="ELinks"
if Instr(strUA,"jbrowser")>0 then arrInfo(0)="JBrowser"
if Instr(strUA,"konqueror")>0 then arrInfo(0)="konqueror"
if Instr(strUA,"wget")>0 then arrInfo(0)="wget"
if Instr(strUA,"ask jeeves")>0 or Instr(strUA,"teoma")>0 then arrInfo(0)="Ask Jeeves/Teoma"
if Instr(strUA,"wget")>0 then arrInfo(0)="wget"
if Instr(strUA,"opera")>0 then arrInfo(0)="opera"

if Instr(strUA,"gecko")>0 then 
strType="[Gecko]"
arrInfo(0)="Mozilla"
if Instr(strUA,"aol")>0 then arrInfo(0)="AOL"
if Instr(strUA,"netscape")>0 then arrInfo(0)="Netscape"
if Instr(strUA,"firefox")>0 then arrInfo(0)="FireFox"
if Instr(strUA,"chimera")>0 then arrInfo(0)="Chimera"
if Instr(strUA,"camino")>0 then arrInfo(0)="Camino"
if Instr(strUA,"galeon")>0 then arrInfo(0)="Galeon"
if Instr(strUA,"k-meleon")>0 then arrInfo(0)="K-Meleon"
arrInfo(0)=arrInfo(0)+strType
end if

if Instr(strUA,"bot")>0 or Instr(strUA,"crawl")>0 then 
strType="[Bot/Crawler]"
arrInfo(0)=""
if Instr(strUA,"grub")>0 then arrInfo(0)="Grub"
if Instr(strUA,"googlebot")>0 then arrInfo(0)="GoogleBot"
if Instr(strUA,"msnbot")>0 then arrInfo(0)="MSN Bot"
if Instr(strUA,"slurp")>0 then arrInfo(0)="Yahoo! Slurp"
arrInfo(0)=arrInfo(0)+strType
end if

if Instr(strUA,"applewebkit")>0 then 
strType="[AppleWebKit]"
arrInfo(0)=""
if Instr(strUA,"omniweb")>0 then arrInfo(0)="OmniWeb"
if Instr(strUA,"safari")>0 then arrInfo(0)="Safari"
arrInfo(0)=arrInfo(0)+strType
end if 

if Instr(strUA,"msie")>0 then 
strType="[MSIE"
temp1=mid(strUA,(Instr(strUA,"msie")+4),6)
temp2=Instr(temp1,";")
temp1=left(temp1,temp2-1)
strType=strType & temp1 &"]"
arrInfo(0)="Internet Explorer"
if Instr(strUA,"msn")>0 then arrInfo(0)="MSN"
if Instr(strUA,"aol")>0 then arrInfo(0)="AOL"
if Instr(strUA,"webtv")>0 then arrInfo(0)="WebTV"
if Instr(strUA,"myie2")>0 then arrInfo(0)="MyIE2"
if Instr(strUA,"maxthon")>0 then arrInfo(0)="Maxthon"
if Instr(strUA,"gosurf")>0 then arrInfo(0)="GoSurf"
if Instr(strUA,"netcaptor")>0 then arrInfo(0)="NetCaptor"
if Instr(strUA,"sleipnir")>0 then arrInfo(0)="Sleipnir"
if Instr(strUA,"avant browser")>0 then arrInfo(0)="AvantBrowser"
if Instr(strUA,"greenbrowser")>0 then arrInfo(0)="GreenBrowser"
if Instr(strUA,"slimbrowser")>0 then arrInfo(0)="SlimBrowser"
arrInfo(0)=arrInfo(0)+strType
end if

'操作系统判断
if Instr(strUA,"windows")>0 then arrInfo(1)="Windows"
if Instr(strUA,"windows ce")>0 then arrInfo(1)="Windows CE"
if Instr(strUA,"windows 95")>0 then arrInfo(1)="Windows 95"
if Instr(strUA,"win98")>0 then arrInfo(1)="Windows 98"
if Instr(strUA,"windows 98")>0 then arrInfo(1)="Windows 98"
if Instr(strUA,"windows 2000")>0 then arrInfo(1)="Windows 2000"
if Instr(strUA,"windows xp")>0 then arrInfo(1)="Windows XP"

if Instr(strUA,"windows nt")>0 then
arrInfo(1)="Windows NT"
if Instr(strUA,"windows nt 5.0")>0 then arrInfo(1)="Windows 2000"
if Instr(strUA,"windows nt 5.1")>0 then arrInfo(1)="Windows XP"
if Instr(strUA,"windows nt 5.2")>0 then arrInfo(1)="Windows 2003"
end if
if Instr(strUA,"x11")>0 or Instr(strUA,"unix")>0 then arrInfo(1)="Unix"
if Instr(strUA,"sunos")>0 or Instr(strUA,"sun os")>0 then arrInfo(1)="SUN OS"
if Instr(strUA,"powerpc")>0 or Instr(strUA,"ppc")>0 then arrInfo(1)="PowerPC"
if Instr(strUA,"macintosh")>0 then arrInfo(1)="Mac"
if Instr(strUA,"mac osx")>0 then arrInfo(1)="MacOSX"
if Instr(strUA,"freebsd")>0 then arrInfo(1)="FreeBSD"
if Instr(strUA,"linux")>0 then arrInfo(1)="Linux"
if Instr(strUA,"palmsource")>0 or Instr(strUA,"palmos")>0 then arrInfo(1)="PalmOS"
if Instr(strUA,"wap ")>0 then arrInfo(1)="WAP"

'arrInfo(0)=strUA 
getBrowser=arrInfo
end function

'*************************************
'检测系统组件是否安装
'*************************************
Function CheckObjInstalled(strClassString)
 On Error Resume Next
 Dim Temp
 Err = 0
 Dim TmpObj
 Set TmpObj = Server.CreateObject(strClassString)
 Temp = Err
 IF Temp = 0 OR Temp = -2147221477 Then
  CheckObjInstalled=true
 ElseIF Temp = 1 OR Temp = -2147221005 Then
  CheckObjInstalled=false
 End IF
 Err.Clear
 Set TmpObj = Nothing
 Err = 0
End Function

'*************************************
'判断服务器Microsoft.XMLDOM
'*************************************
Function getXMLDOM
 On Error Resume Next
 Dim Temp
 getXMLDOM="Microsoft.XMLDOM"
 Err = 0
 Dim TmpObj
 Set TmpObj = Server.CreateObject(getXMLDOM)
 Temp = Err
IF Temp = 1 OR Temp = -2147221005 Then
  getXMLDOM="Msxml2.DOMDocument.5.0"
 End IF
 Err.Clear
 Set TmpObj = Nothing
 Err = 0
end function

'*************************************
'判断服务器MSXML2.ServerXMLHTTP
'*************************************
Function getXMLHTTP
 On Error Resume Next
 Dim Temp
 getXMLHTTP="MSXML2.ServerXMLHTTP"
 Err = 0
 Dim TmpObj
 Set TmpObj = Server.CreateObject(getXMLHTTP)
 Temp = Err
IF Temp = 1 OR Temp = -2147221005 Then
  getXMLHTTP="Msxml2.ServerXMLHTTP.5.0"
 End IF
 Err.Clear
 Set TmpObj = Nothing
 Err = 0
end function

'*************************************
'检查插件是否成功安装
'*************************************
Function Checkplugins 
Dim PlugS,Plug,PlugItem
Checkplugins=-1
PlugS=Split(function_Plugin,"$*$")
For Each Plug In PlugS
PlugItem = Split(Plug,"%|%")
If Getplugins=PlugItem(0) Then 
Checkplugins=PlugItem
Exit Function
End If
Next
End Function 
'//验证码控制
sub codestt(codestr)
If codestr="" Then
  tourlRedirect("请返回输入确认码。返回后请刷新登录页面后重新输入正确的信息。")
  response.End()
  Exit Sub
 Elseif Session("getcode")="9999" then
  Session("getcode")=""
 Elseif Session("getcode")="" then
  tourlRedirect("请不要重复提交，如需重新登录请返回登录页面。")
  response.End()
  Exit Sub
 ElseIf Cstr(Session("GetCode"))<>Cstr(trim(codestr)) Then
  tourlRedirect("您输入的确认码和系统产生的不一致，请重新输入。返回后请刷新登录页面后重新输入正确的信息!")
  response.End()
  Exit Sub
 End If
 Session("getcode")=""
end sub
'转换时间函数//年月日
function yl_addnow(addnow)
'dim yl_yearr,yl_mmm,yl_ddd,yl_hhh,yl_nnn,yl_sss
'yl_yearr=datepart("yyyy",addnow)
'yl_mmm=datepart("m",addnow)
'yl_ddd=datepart("d",addnow)
'yl_hhh=datepart("h",addnow)
'yl_nnn=datepart("n",addnow)
'yl_sss=datepart("s",addnow)
'yl_addnow=""&yl_yearr&"年"&yl_mmm&"月"&yl_ddd&"日 "&yl_hhh&"时"&yl_nnn&"分"&yl_sss&"秒"
dim yl_year,yl_month,yl_day,yl_hour,yl_minute,yl_ss
yl_year=year(addnow)
if len(yl_year)=2 then yl_year="20"&yl_year
yl_month=month(addnow)
if yl_month<10 then yl_month="0"&yl_month
yl_day=day(addnow)
if yl_day<10 then yl_day="0"&yl_day 
yl_hour=hour(addnow)
if yl_hour<10 then yl_hour="0"&yl_hour
yl_minute=minute(addnow)
if yl_minute<10 then yl_minute="0"&yl_minute
yl_ss=second(addnow)
if yl_ss<10 then yl_ss="0"&yl_ss
yl_addnow=""&yl_year&"年"&yl_month&"月"&yl_day&"日 "&yl_hour&"时"&yl_minute&"分"&yl_ss&"秒"
end function
'转换日期时间函数
function yl_now(nowtime)
'yl_now = year(nowtime)&month(nowtime)&day(nowtime)&hour(nowtime)&minute(nowtime)&second(nowtime)
dim yl_year,yl_month,yl_day,yl_hour,yl_minute,yl_ss
yl_year=year(nowtime)
if len(yl_year)=2 then yl_year="20"&yl_year
yl_month=month(nowtime)
if yl_month<10 then yl_month="0"&yl_month
yl_day=day(nowtime)
if yl_day<10 then yl_day="0"&yl_day 
yl_hour=hour(nowtime)
if yl_hour<10 then yl_hour="0"&yl_hour
yl_minute=minute(nowtime)
if yl_minute<10 then yl_minute="0"&yl_minute
yl_ss=second(nowtime)
if yl_ss<10 then yl_ss="0"&yl_ss
yl_now=""&yl_year&""&yl_month&""&yl_day&""&yl_hour&""&yl_minute&""&yl_ss&""
end function
'转换日期函数
function yl_date(nowdate)
'yl_date=""&year(nowdate)&"-"&month(nowdate)&"-"&day(nowdate)&""
dim yl_year,yl_month,yl_day,yl_hour,yl_minute,yl_ss
yl_year=year(nowdate)
if len(yl_year)=2 then yl_year="20"&yl_year
yl_month=month(nowdate)
if yl_month<10 then yl_month="0"&yl_month
yl_day=day(nowdate)
if yl_day<10 then yl_day="0"&yl_day
yl_date = ""&yl_year&"-"&yl_month&"-"&yl_day&""
end function

'*************************************
'日期转换函数
'*************************************
Function DateToStr(DateTime,ShowType) 
 Dim DateMonth,DateDay,DateHour,DateMinute,DateWeek,DateSecond
 Dim FullWeekday,shortWeekday,Fullmonth,Shortmonth,TimeZone1,TimeZone2
 TimeZone1="+0800"
 TimeZone2="+08:00"
 FullWeekday=Array("Sunday","Monday","Tuesday","Wednesday","Thursday","Friday","Saturday")
 shortWeekday=Array("Sun","Mon","Tue","Wed","Thu","Fri","Sat")
Fullmonth=Array("January","February","March","April","May","June","July","August","September","October","November","December")
Shortmonth=Array("Jan","Feb","Mar","Apr","May","Jun","Jul","Aug","Sep","Oct","Nov","Dec")

 DateMonth=Month(DateTime)
 DateDay=Day(DateTime)
 DateHour=Hour(DateTime)
 DateMinute=Minute(DateTime)
 DateWeek=weekday(DateTime)
 DateSecond=Second(DateTime)
 If Len(DateMonth)<2 Then DateMonth="0"&DateMonth
 If Len(DateDay)<2 Then DateDay="0"&DateDay
 If Len(DateMinute)<2 Then DateMinute="0"&DateMinute
 Select Case ShowType
 Case "Y-m-d" 
  DateToStr=Year(DateTime)&"-"&DateMonth&"-"&DateDay
 Case "Y-m-d H:I A"
  Dim DateAMPM
  If DateHour>12 Then 
   DateHour=DateHour-12
   DateAMPM="PM"
  Else
   DateHour=DateHour
   DateAMPM="AM"
  End If
  If Len(DateHour)<2 Then DateHour="0"&DateHour 
  DateToStr=Year(DateTime)&"-"&DateMonth&"-"&DateDay&" "&DateHour&":"&DateMinute&" "&DateAMPM
 Case "Y-m-d H:I:S"
  If Len(DateHour)<2 Then DateHour="0"&DateHour 
  If Len(DateSecond)<2 Then DateSecond="0"&DateSecond
  DateToStr=Year(DateTime)&"-"&DateMonth&"-"&DateDay&" "&DateHour&":"&DateMinute&":"&DateSecond
 Case "YmdHIS"
  DateSecond=Second(DateTime)
  If Len(DateHour)<2 Then DateHour="0"&DateHour 
  If Len(DateSecond)<2 Then DateSecond="0"&DateSecond
  DateToStr=Year(DateTime)&DateMonth&DateDay&DateHour&DateMinute&DateSecond 
 Case "ym"
  DateToStr=Right(Year(DateTime),2)&DateMonth
 Case "d"
  DateToStr=DateDay
Case "ymd"
DateToStr=Right(Year(DateTime),4)&DateMonth&DateDay
Case "mdy" 
Dim DayEnd
select Case DateDay
Case 1 
DayEnd="st"
Case 2
DayEnd="nd"
Case 3
DayEnd="rd"
Case Else
DayEnd="th"
End Select 
DateToStr=Fullmonth(DateMonth-1)&" "&DateDay&DayEnd&" "&Right(Year(DateTime),4)
Case "w,d m y H:I:S" 
  DateSecond=Second(DateTime)
  If Len(DateHour)<2 Then DateHour="0"&DateHour 
  If Len(DateSecond)<2 Then DateSecond="0"&DateSecond
DateToStr=shortWeekday(DateWeek-1)&","&DateDay&" "& Left(Fullmonth(DateMonth-1),3) &" "&Right(Year(DateTime),4)&" "&DateHour&":"&DateMinute&":"&DateSecond&" "&TimeZone1
Case "y-m-dTH:I:S"
  If Len(DateHour)<2 Then DateHour="0"&DateHour 
  If Len(DateSecond)<2 Then DateSecond="0"&DateSecond
  DateToStr=Year(DateTime)&"-"&DateMonth&"-"&DateDay&"T"&DateHour&":"&DateMinute&":"&DateSecond&TimeZone2
 Case Else
  If Len(DateHour)<2 Then DateHour="0"&DateHour
  DateToStr=Year(DateTime)&"-"&DateMonth&"-"&DateDay&" "&DateHour&":"&DateMinute
 End Select
End Function
'*************************************
'计算随机数
'*************************************
function randomStr(intLength)
dim strSeed,seedLength,pos,str,i
strSeed = "abcdefghijklmnopqrstuvwxyz1234567890"
seedLength=len(strSeed)
str=""
Randomize
for i=1 to intLength
str=str+mid(strSeed,int(seedLength*rnd)+1,1)
next
randomStr=str
end function

'生成随机字符串开始
Function Createpass(LengthNum)
Dim Ran,i 
if Not IsNumeric(LengthNum) then LengthNum=16 
Createpass="" 
For i=1 To LengthNum 
Randomize 
Ran = CInt(Rnd * 2) 
Randomize 
If Ran = 0 Then 
Ran = CInt(Rnd * 25) + 97 
Createpass =Createpass& UCase(Chr(Ran)) 
ElseIf Ran = 1 Then 
Ran = CInt(Rnd * 9) 
Createpass = Createpass & Ran 
ElseIf Ran = 2 Then 
Ran = CInt(Rnd * 25) + 97 
Createpass =Createpass& Chr(Ran) 
End If 
Next 
End Function
'调用...
'ranNum=Createpass(15)
'randomize 
'ranNum=int(90000*rnd)+10000
'生成随机字符串结束

'模版替换函数开始
Function TempletContent(TempletContents)
TempletContent=replace(TempletContents,"$homepage_url$",homepage_url) '网站域名替换模版
 TempletContent=replace(TempletContent,"$homepage_link$",homepage_link) '网站首页替换模版
 TempletContent=replace(TempletContent,"$news_location$",news_location) '网站目录替换模版
 TempletContent=replace(TempletContent,"$metas$",metas) 'meta替换模版
 TempletContent=replace(TempletContent,"$info_table$",info_table) '网页宽度替换模版
 TempletContent=replace(TempletContent,"$t_images$",t_images) '栏目分类图标替换模版
 TempletContent=replace(TempletContent,"$ntype$",ntype) '栏目分类替换模版
 TempletContent=replace(TempletContent,"$yl_infoclass$",ntypeid) '栏目分类ID替换模版
 TempletContent=replace(TempletContent,"$typeurl$",typeurl) '栏目分类地址替换模版
 TempletContent=replace(TempletContent,"$yl_title$",yl_title) '标题替换模版
 TempletContent=replace(TempletContent,"$adddate$",adddate) '时间替换模版
 'TempletContent=replace(TempletContent,"$testcodes$",testcodes) '内容替换模版
 TempletContent=replace(TempletContent,"$yl_name$",yl_name) '作者替换模版
 TempletContent=replace(TempletContent,"$yl_xxly$",yl_xxly) '来源替换模版

End Function
'模版替换函数结束
'====================================生成HTML开始
'定义xmlhttp
function GetXmlText(Url)
dim GetXmlHttp

set GetXmlHttp=server.Createobject("Microsoft.XMLHTTP")
GetXmlHttp.open "Get",url,false,"",""
GetXmlHttp.Send
'GetXmlText=GetXmlHttp.Responsetext
GetXmlText=GetXmlHttp.ResponseBody
set GetXmlHttp=nothing
end function

一些小asp的函数(2)

 

'转换为字符
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
'保存文件
Sub SaveToFile(strBody,File)
Dim objStream
Set objStream = Server.CreateObject("ADODB.Stream")
With objStream
.Type = 2
.Open
.Charset = "GB2312"
.Position = objStream.Size
.WriteText = strBody
.SaveToFile Server.MapPath(File),2
.Close
End With
Set objStream = Nothing
End Sub
'创建文件
Sub FSOSaveFile(Content,LocalFileName)
 Dim FileObj,FilePionter
 'response.write LocalFileName
 'response.end
 Set FileObj=Server.CreateObject(G_FS_FSO)
 Set FilePionter = FileObj.CreateTextFile(Server.MapPath(LocalFileName),True) 
 FilePionter.Write Replace(Content,Webdomain,"")
 FilePionter.close '释放对象
 Set FilePionter = Nothing
 Set FileObj = Nothing
End Sub
'====================================生成HTML结束
'截取信息开始
'strs=rsinfoall("yl_body")
 'bodys=stripHTML(strs)
 'bodys=cutStr(bodys,350)
Function stripHTML(strHTML)
Dim objRegExp, strOutput
Set objRegExp = New Regexp
objRegExp.IgnoreCase = True
objRegExp.Global = True
objRegExp.Pattern = "<(.[^>]*)>" 
strOutput = objRegExp.Replace(strHTML, "") 
strOutput = Replace(strOutput, "<", "<")
strOutput = Replace(strOutput, ">", ">")
stripHTML = strOutput
Set objRegExp = Nothing
End Function
function cutStr(strs,strlen)
dim l,t,c,i
l=len(strs)
t=0
for i=1 to l
c=Abs(Asc(Mid(strs,i,1)))
if c>255 then
t=t+2
else
t=t+1
end if
if t>=strlen then
cutStr=left(strs,i)&"..."
exit for
else
cutStr=strs
end if
next
cutStr=replace(cutStr,chr(10),"")
  cutStr=Replace(cutStr,chr(13),"")
end function 
'截取信息结束
'*************************************
'切割内容 - 按行分割
'*************************************
Function SplitLines(byVal Content,byVal ContentNums) 
 Dim ts,i,l
 ContentNums=int(ContentNums)
 If IsNull(Content) Then Exit Function
 i=1
 ts = 0
 For i=1 to Len(Content)
l=Lcase(Mid(Content,i,5))
 If l="<br/>" Then
 ts=ts+1
 End If
l=Lcase(Mid(Content,i,4))
 If l="<br>" Then
 ts=ts+1
 End If
l=Lcase(Mid(Content,i,3))
 If l="<p>" Then
 ts=ts+1
 End If
 If ts>ContentNums Then Exit For 
 Next
 If ts>ContentNums Then
 Content=Left(Content,i-1)
 End If
 SplitLines=Content
End Function

'*************************************
'切割内容 - 按字符分割
'*************************************
Function CutStr(byVal Str,byVal StrLen)
 Dim l,t,c,i
 If IsNull(Str) Then CutStr="":Exit Function
 l=Len(str)
 StrLen=int(StrLen)
 t=0
 For i=1 To l
  c=Asc(Mid(str,i,1))
  If c<0 Or c>255 Then t=t+2 Else t=t+1
  IF t>=StrLen Then
   CutStr=left(Str,i)&".."
   Exit For
  Else
   CutStr=Str
  End If
 Next
End Function
'//按字截取
Function IStrLen(TempStr)
 Dim iLen,i,StrAsc
 iLen=0
 for i=1 to len(TempStr)
   StrAsc=Abs(Asc(Mid(TempStr,i,1)))
   if StrAsc>255 then
    iLen=iLen+2
   else
    iLen=iLen+1
   end if
 next
 IStrLen=iLen
End Function
'*************************************
'转换HTML代码
'*************************************
Function HTMLEncode(ByVal reString) 
 Dim Str:Str=reString
 If Not IsNull(Str) Then
  Str = Replace(Str, ">", ">")
  Str = Replace(Str, "<", "<")
  Str = Replace(Str, CHR(9), " ")
  Str = Replace(Str, CHR(39), "'")
 Str = Replace(Str, CHR(34), """)
  Str = Replace(Str, CHR(13), "")
  Str = Replace(Str, CHR(10), "<br/>")
  HTMLEncode = Str
 End If
End Function
'*************************************
'反转换HTML代码
'*************************************
Function HTMLDecode(ByVal reString) 
 Dim Str:Str=reString
 If Not IsNull(Str) Then
  Str = Replace(Str, ">", ">")
  Str = Replace(Str, "<", "<")
  Str = Replace(Str, " ", CHR(9))
  Str = Replace(Str, "    ", CHR(9))
  Str = Replace(Str, "'", CHR(39))
  Str = Replace(Str, """, CHR(34))
  Str = Replace(Str, "", CHR(13))
  Str = Replace(Str, "<br/>", CHR(10))
  HTMLDecode = Str
 End If
End Function
'*************************************
'过滤textarea
'*************************************
Function UBBFilter(ByVal reString)
 Dim Str:Str=reString
 If Not IsNull(Str) Then
  Str = Replace(Str, "</textarea>", "</textarea>")
  UBBFilter = Str
 End If
End Function
'*************************************
'过滤HTML代码
'*************************************
Function EditDeHTML(byVal Content)
 EditDeHTML=Content
 IF Not IsNull(EditDeHTML) Then
  EditDeHTML=UnCheckStr(EditDeHTML)
  EditDeHTML=Replace(EditDeHTML,"&","&")
  EditDeHTML=Replace(EditDeHTML,"<","<")
  EditDeHTML=Replace(EditDeHTML,">",">")
  EditDeHTML=Replace(EditDeHTML,chr(34),""")
  EditDeHTML=Replace(EditDeHTML,chr(39),"'")
 End IF
End Function

'*************************************
'过滤文件名字
'*************************************
Function repbody(ylFileExt)
 If IsEmpty(ylFileExt) Then Exit Function
 repbody = Lcase(ylFileExt)
 repbody = Replace(repbody,Chr(0),"")
 repbody = Replace(repbody,".","")
 repbody = Replace(repbody,"asp","")
 repbody = Replace(repbody,"asa","")
 repbody = Replace(repbody,"aspx","")
 repbody = Replace(repbody,"cer","")
 repbody = Replace(repbody,"cdx","")
 repbody = Replace(repbody,"htr","")
 repbody = Replace(repbody,"php","")
 repbody = Replace(repbody,"jsp","")
 repbody = Replace(repbody,"js","")
 repbody = Replace(repbody,"iframe","")
 repbody = Replace(repbody,"object","")
 repbody = Replace(repbody,"script","")
 repbody = Replace(repbody,".txt","")
 repbody = Replace(repbody,".swf","")
 repbody = Replace(repbody,".dat","")
 repbody = Replace(repbody,".dll","")
 repbody = Replace(repbody,".exe","")
 repbody = Replace(repbody,".bat","")
End Function
Function FixName(UpFileExt)
 If IsEmpty(UpFileExt) Then Exit Function
 FixName = Ucase(UpFileExt)
 FixName = Replace(FixName,Chr(0),"")
 FixName = Replace(FixName,".","")
 FixName = Replace(FixName,"ASP","")
 FixName = Replace(FixName,"ASA","")
 FixName = Replace(FixName,"ASPX","")
 FixName = Replace(FixName,"CER","")
 FixName = Replace(FixName,"CDX","")
 FixName = Replace(FixName,"HTR","")
End Function

'*************************************
'过滤特殊字符
'*************************************
Function CheckStr(byVal ChkStr) 
 Dim Str:Str=ChkStr
 Str=Trim(Str)
 If IsNull(Str) Then
  CheckStr = ""
  Exit Function 
 End If
Str = Replace(Str, "&", "&")
Str = Replace(Str,"'","'")
Str = Replace(Str,"""",""")
 Dim re
 Set re=new RegExp
 re.IgnoreCase =True
 re.Global=True
 re.Pattern="(w)(here)"
Str = re.replace(Str,"$1here")
 re.Pattern="(s)(elect)"
Str = re.replace(Str,"$1elect")
 re.Pattern="(i)(nsert)"
Str = re.replace(Str,"$1nsert")
 re.Pattern="(c)(reate)"
Str = re.replace(Str,"$1reate")
 re.Pattern="(d)(rop)"
Str = re.replace(Str,"$1rop")
 re.Pattern="(a)(lter)"
Str = re.replace(Str,"$1lter")
 re.Pattern="(d)(elete)"
Str = re.replace(Str,"$1elete")
 re.Pattern="(u)(pdate)"
Str = re.replace(Str,"$1pdate")
 re.Pattern="(\s)(or)"
Str = re.replace(Str,"$1or")
 Set re=Nothing
 CheckStr=Str
End Function
'*************************************
'过滤超链接
'*************************************
Function checkURL(ByVal ChkStr)
 Dim str:str=ChkStr
 str=Trim(str)
 If IsNull(str) Then
  checkURL = ""
  Exit Function 
 End If
 Dim re
 Set re=new RegExp
 re.IgnoreCase =True
 re.Global=True
 re.Pattern="(d)(ocument\.cookie)"
Str = re.replace(Str,"$1ocument cookie")
 re.Pattern="(d)(ocument\.write)"
Str = re.replace(Str,"$1ocument write")
 re.Pattern="(s)(cript:)"
Str = re.replace(Str,"$1cript ")
 re.Pattern="(s)(cript)"
Str = re.replace(Str,"$1cript")
 re.Pattern="(o)(bject)"
Str = re.replace(Str,"$1bject")
 re.Pattern="(a)(pplet)"
Str = re.replace(Str,"$1pplet")
 re.Pattern="(e)(mbed)"
Str = re.replace(Str,"$1mbed")
 Set re=Nothing
 Str = Replace(Str, ">", ">")
 Str = Replace(Str, "<", "<")
 checkURL=Str 
end function
'内容： ASP中解码或反编码用server.urlencode编码的字符 start
'用法:URLDecode(enStr)
Function URLDecode(enStr)
dim deStr
dim c,i,v
deStr=""
for i=1 to len(enStr)
c=Mid(enStr,i,1)
if c="%" then
v=eval("&h"+Mid(enStr,i+1,2))
if v<128 then
deStr=deStr&chr(v)
i=i+2
else
if isvalidhex(mid(enstr,i,3)) then
if isvalidhex(mid(enstr,i+3,3)) then
v=eval("&h"+Mid(enStr,i+1,2)+Mid(enStr,i+4,2))
deStr=deStr&chr(v)
i=i+5
else
v=eval("&h"+Mid(enStr,i+1,2)+cstr(hex(asc(Mid(enStr,i+3,1)))))
deStr=deStr&chr(v)
i=i+3 
end if 
else 
destr=destr&c
end if
end if
else
if c="+" then
deStr=deStr&" "
else
deStr=deStr&c
end if
end if
next
URLDecode=deStr
end function
function isvalidhex(str)
isvalidhex=true
str=ucase(str)
if len(str)<>3 then isvalidhex=false:exit function
if left(str,1)<>"%" then isvalidhex=false:exit function
c=mid(str,2,1)
if not (((c>="0") and (c<="9")) or ((c>="A") and (c<="Z"))) then isvalidhex=false:exit function
c=mid(str,3,1)
if not (((c>="0") and (c<="9")) or ((c>="A") and (c<="Z"))) then isvalidhex=false:exit function
end function
'内容： ASP中解码或反编码用server.urlencode编码的字符 end

'//水印
'call jpegclass("images_admin/header_blue.jpg",14,"宋体",0,20,250,"http://www.115000.com.cn/")
'response.write "<img src=images_admin/header_blue.jpg border=0>"
'//rem call jpegclass("images_admin/header_blue.jpg",14,"宋体",1,18,18,"http://www.115000.com.cn/")
Sub jpegclass(imgurl,fontsize,family,isbold,top,leftf,content) '调用过程名 
Dim jpeg,font_color,font_size,font_family,f_width,f_height,f_content
'建立实例
Set jpeg = server.CreateObject("Persits.jpeg")
font_size = 10
font_fanily = "宋体"
f_left = 5
f_top = 5
if imgurl <> "" then
jpeg.open server.MapPath(imgurl) '图片路径并打开它
else
response.write "未找到图片路径"
exit sub
end if 
if fontsize <> "" then font_size = fontsize '字体大小
if family <> "" then font_family = family '字体
if top <> "" then f_top = top '水印离图片top位置
if leftf <> "" then f_left = leftf '水印离图片左边位置
if content = "" then
response.write "水印什么内容呢，水印不成功！"
exit sub
else
f_content = content '水印内容
end if
'添加文字水印
jpeg.canvas.font.color = &hffffff' 红色
jpeg.canvas.font.family = font_family
jpeg.canvas.font.size = font_size
if isbold=1 then 
Jpeg.Canvas.Font.Bold = True 
end if 
jpeg.canvas.print f_left , f_top , f_content
'保存文件
jpeg.save server.MapPath(imgurl)
'注销对象
set jpeg = nothing
' response.write "水印成功，图片上加了  "&content&""
end sub 

''自动分页
Function AutoSplitPages(StrNewsContent)
Dim Inti,StrTrueContent,iPageLen,DLocation,XLocation,FoundStr
 If StrNewsContent<>"" and AutoPagesNum<>0 and instr(1,StrNewsContent,"$Page_Split$")=0 then
  Inti=instr(1,StrNewsContent,"<")
  If inti>=1 then '新闻中存在Html标记
   StrTrueContent=left(StrNewsContent,Inti-1)
   iPageLen=IStrLen(StrTrueContent)
   inti=inti+1
  Else   '新闻中不存在Html标记，对内容直接分页即可
   dim i,c,t
   do while i< len(StrNewsContent)
   i=i+1
    c=Abs(Asc(Mid(StrNewsContent,i,1)))
    if c>255 then '判断为汉字则为两个字符，英文为一个字符
     t=t+2
    else
     t=t+1
    end if
    if t>=AutoPagesNum then  '如果字数达到了分页的数量则插入分页符号
     StrNewsContent=left(StrNewsContent,i)&"$Page_Split$"&mid(StrNewsContent,i+1)
     i=i+6
     t=0
    end if
   loop
   AutoSplitPages=StrNewsContent '返回插入分页符号的内容
   Exit Function
  End If
  iPageLen=0
  '新闻中存在Html标记时，则用下面的语句来处理
  do while instr(Inti,StrNewsContent,">")<>0
   DLocation=instr(Inti,StrNewsContent,">")  '只计算Html标记之外的字符数量
   XLocation=instr(DLocation,StrNewsContent,"<")
   If XLocation>DLocation+1 then
    Inti=XLocation
    StrTrueContent=mid(StrNewsContent,DLocation+1,XLocation-DLocation-1)
    iPageLen=iPageLen+IStrLen(StrTrueContent) '统计Html之外的字符的数量
    If iPageLen>AutoPagesNum then    '如果达到了分页的数量则插入分页字符
     FoundStr=Lcase(left(StrNewsContent,XLocation-1))
     If AllowSplitPages(FoundStr,"table|a|b>|i>|strong|div")=true then
      StrNewsContent=left(StrNewsContent,XLocation-1)&"$Page_Split$"&mid(StrNewsContent,XLocation)
      iPageLen=0        '重新统计Html之外的字符
     End If
    End If
   ElseIf XLocation=0 then       '在后面再也找不到<，即后面没有Html标记了
    Exit Do
   ElseIf XLocation=DLocation+1 then    '找到的Html标记之间的内容为空，则继续向后找
    Inti=XLocation
   End If
  loop
 End If
AutoSplitPages=StrNewsContent
End Function

'*************************************
'分页函数
'*************************************
dim FirstShortCut,ShortCut
FirstShortCut=false
Function MultiPage(Numbers,Perpage,Curpage,Url_Add,aname,Style) 
 CurPage=Int(Curpage)
 Numbers=Int(Numbers)
 Dim URL
 URL=Request.ServerVariables("Script_Name")&Url_Add
 MultiPage=""
 Dim Page,Offset,PageI
' If Int(Numbers)>Int(PerPage) Then
  Page=9
  Offset=4
  Dim Pages,FromPage,ToPage
  If Numbers Mod Cint(Perpage)=0 Then
   Pages=Int(Numbers/Perpage)
  Else
   Pages=Int(Numbers/Perpage)+1
  End If
  FromPage=Curpage-Offset
  ToPage=Curpage+Page-Offset-1
  If Page>Pages Then
   FromPage=1
   ToPage=Pages
  Else
   If FromPage<1 Then
    Topage=Curpage+1-FromPage
    FromPage=1
    If (ToPage-FromPage)<Page And (ToPage-FromPage)<Pages Then ToPage=Page
   ElseIF Topage>Pages Then
    FromPage =Curpage-Pages +ToPage
    ToPage=Pages
    If (ToPage-FromPage)<Page And (ToPage-FromPage)<Pages Then FromPage=Pages-Page+1
   End If
  End If
   MultiPage="<div class=""page"" style="""&Style&"""><ul>"
  'if Curpage<>1 then MultiPage=MultiPage&"<li class=""PageL""><a href="""&Url&"page=1"" class=""PageLbutton"" title=""第一页""></a></li>"
  MultiPage=MultiPage&"<li class=""pageNumber"">"
  if Curpage<>1 then MultiPage=MultiPage&"<a href="""&Url&"page=1"" title=""第一页"" style=""text-decoration:none""><</a> | "
  if not FirstShortCut then ShortCut=" accesskey="",""" else ShortCut=""
  if Curpage<>1 then MultiPage=MultiPage&"<a href="""&Url&"page="&CurPage-1&""" title=""上一页"" style=""text-decoration:none;"""&ShortCut&"></a>"
  For PageI=FromPage TO ToPage
   If PageI<>CurPage Then
    MultiPage=MultiPage&"<a href="""&Url&"page="&PageI&aname&""">"&PageI&"</a> | "
   Else
    MultiPage=MultiPage&"<strong>"&PageI&"</strong>"
    if PageI<>Pages then MultiPage=MultiPage&" | "
   End If
  Next
  if not FirstShortCut then ShortCut=" accesskey="".""" else ShortCut=""
  if Curpage<>pages then MultiPage=MultiPage&"<a href="""&Url&"page="&CurPage+1&""" title=""下一页"" style=""text-decoration:none"""&ShortCut&"></a>"
  if Curpage<>pages then MultiPage=MultiPage&"<a href="""&Url&"page="&Pages&aname&""" title=""最后一页"" style=""text-decoration:none"">></a>"
  MultiPage=MultiPage&"</li>"
  'If Int(Pages)>Int(Page) Then
  ' MultiPage=MultiPage&"<li>...</li><li><a href="""&Url&"page="&Pages&aname&""">"&pages&"</a></li>"
  'End If
  'if Curpage<>pages then MultiPage=MultiPage&"<li class=""PageR""><a href="""&Url&"page="&Pages&aname&""" class=""PageRbutton"" title=""最后一页""></a></li>"
  MultiPage=MultiPage&"</ul></div>"
' End If
FirstShortCut=true
End Function

'过滤跨站脚本和HTML标签
Function NoCSSHackInput(Str)
 Dim regEx
 Set regEx = New RegExp
 regEx.IgnoreCase = True
 regEx.Pattern = "<|>|(script)|on(mouseover|mouseon|mouseout|click|dblclick|blur|focus|change)|url|eval|\t"
 If regEx.Test(LCase(Str)) Then
  Response.Write "<script>alert('你的输入含有非法字符(<,>,tab,script等)，请检查后再提交！');history.back();</script>"
  Response.End
 End If
 Set regEx = Nothing
 NoCSSHackInput = Str
End Function
'过滤跨站脚本，只过滤脚本，对HTML不过滤
Function NoCSSHackContent(Str) 
 Dim regEx
 Set regEx = New RegExp
 regEx.IgnoreCase = True
 regEx.Pattern = "iframe|object|(script)|on(mouseover|mouseon|mouseout|click|dblclick|blur|focus|change)|(url\()|eval"
 If regEx.Test(LCase(Str)) Then