ASP常用函数大收集01[大部分来自网络]

于 2007-11-23 16:24:00 发布
阅读量634 收藏
点赞数
文章标签： asp 网络 function windows timezone mozilla
版权声明：本文为博主原创文章，遵循 CC 4.0 BY-SA 版权协议，转载请附上原文出处链接和本声明。
本文链接：https://blog.csdn.net/Tony088/article/details/1899618
版权
<%
'*************************************
'防止外部提交
'*************************************
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=False
  else
    chkpost=True
  end If
  if chkpost=False then
   response.Write "<script>alert('本站点禁止外部提交！');history.go(-1)</script>"
   response.End()
  end if
end function
 
'*************************************
'获得验证码
'************************************* 
Function getcode(path)
  getcode= "<img src="""&path&"getcode.asp"" alt="""" style=""margin-right:20px;""/>" 
End Function
'*************************************
'判断Email格式
'************************************* 
Function IsValidEmail(email)
 dim names,name,i,c
 IsValidEmail = true
 names = Split(email,"@")
 if UBound(names) <> 1 then
  IsValidEmail = false
  exit function
 end if
 
 for each name in names
  if Len(name) <= 0 then
   IsValidEmail = false
   exit function
  end if
 
  for i = 1 to Len(name)
   c = Lcase(Mid(name,i,1))
   if InStr("abcdefghijklmnopqrstuvwxyz_-.",c) <= 0 and not IsNumeric(c) then
    IsValidEmail = false
    exit function
   end if
  next
 
  if Left(name, 1) = "." or Right(name, 1) = "." then
   IsValidEmail = false
   exit function
  end if
 
 next
 
 if InStr(names(1),".") <= 0 then
  IsValidEmail = false
  exit function
 end if
 
 i = Len(names(1)) - InStrRev(names(1),".")
 if i <> 2 and i <> 3 then
  IsValidEmail = false
  exit function
 end if
 
 if InStr(email,"..") > 0 then
  IsValidEmail = false
 end if
end function
'*************************************
'判断Url格式
'************************************* 
Function IsValidUrl(urlstr)
 IsValidUrl=true
 if len(urlstr)<7 then IsValidUrl = false:Exit function
 if left(Lcase(urlstr),7)<>"http://" or len(urlstr)<9 then
  IsValidUrl=false
  exit function
 end if
 whois=Lcase(mid(urlstr,8,Len(urlstr)-8))
 for i = 1 to Len(whois)
  c = Lcase(Mid(whois,i,1))
  if InStr("0123456789abcdefghijklmnopqrstuvwxyz_-.",c) <= 0 then
   IsValidUrl = false
   exit function
  end if
 next
 if InStr(urlstr,"..") > 0 then
  IsValidUrl = false
 end if
End Function
'*************************************
'获取服务器端文件夹大小
'************************************* 
Function GetTotalSize(GetLocal,GetType) '获得目标大小
 Dim FSO
 Set FSO=Server.CreateObject("Scripting.FileSystemObject")
 IF Err<>0 Then
  Err.Clear
  GetTotalSize="Fail"
 Else
  Dim SiteFolder
  IF GetType="Folder" Then
   Set SiteFolder=FSO.GetFolder(GetLocal)
  Else
   Set SiteFolder=FSO.GetFile(GetLocal)
  End IF
  GetTotalSize=SiteFolder.Size
  IF GetTotalSize>1024*1024 Then
  GetTotalSize=GetTotalSize/1024/1024
  IF inStr(GetTotalSize,".") Then GetTotalSize = Left(GetTotalSize,inStr(GetTotalSize,".")+2)
   GetTotalSize=GetTotalSize&" MB"
  Else
   GetTotalSize=Fix(GetTotalSize/1024)&" KB"
  End IF
 
  Set SiteFolder=Nothing
 End IF
 Set FSO=Nothing
End Function
'*************************************
'检查服务器组件是否支持结果输出
'************************************* 
Function DisI(b)
 if b then
   response.write "<span style=""color:#00cc00""><b>支持</b></span>"
  else
   response.write "<span style=""color:#FF0000""><b>不支持</b></span>"
 end if
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
'*************************************
'日期时间格式化
'************************************* 
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 IsValidChars(str)
 Dim re,chkstr
 Set re=new RegExp
 re.IgnoreCase =true
 re.Global=True
 re.Pattern="[^_/.a-zA-Z/d]"
 IsValidChars=True
 chkstr=re.Replace(str,"")
 if chkstr<>str then IsValidChars=False
 set re=nothing
End Function
'*************************************
'过滤超链接
'*************************************
Function checkURL(ByVal str)
 If IsEmpty(str) Then Exit Function
 Str = Lcase(str)
 Str = Replace(Str, ",", "，")
    Str = Replace(Str, ">", " ")
 Str = Replace(Str, "<", " ")
 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,"$1cri&#112;t ")
    re.Pattern="(s)(cript)"
    Str = re.replace(Str,"$1cri&#112;t")
    re.Pattern="(o)(bject)"
    Str = re.replace(Str,"$1bj&#101;ct")
    re.Pattern="(a)(pplet)"
    Str = re.replace(Str,"$1ppl&#101;t")
    re.Pattern="(e)(mbed)"
    Str = re.replace(Str,"$1mb&#101;d")
 Set re=Nothing
 checkURL=Str   
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
'*************************************
'转换HTML代码
'*************************************
Function HTMLEncode(ByVal reString)
 Dim Str:Str=reString
 If Not IsNull(Str) Then
     Str = Replace(Str, ">", "&gt;")
  Str = Replace(Str, "<", "&lt;")
     Str = Replace(Str, CHR(9), "&nbsp;")
     Str = Replace(Str, CHR(39), "&#39;")
     Str = Replace(Str, CHR(34), "&quot;")
  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, "&gt;", ">")
  Str = Replace(Str, "&lt;", "<")
     Str = Replace(Str, "&nbsp;", CHR(9))
  Str = Replace(Str, "&#160;&#160;&#160;&#160;", CHR(9))
  Str = Replace(Str, "&#39;", CHR(39))
  Str = Replace(Str, "&quot;", CHR(34))
  Str = Replace(Str, "", CHR(13))
  Str = Replace(Str, "<br/>", CHR(10))
  HTMLDecode = Str
 End If
End Function
'*************************************
'计算随机数
'*************************************
function randomStr(intLength)
    dim strSeed,seedLength,pos,str,i
    strSeed = "1234567890"
    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 Filterstr(Str)
 If Isnull(Str) Then
  Filterstr = ""
  Exit Function
 End If
 Str = Replace(Str,Chr(0),"",1,-1,1)
 Str = Replace(Str,"""","&quot;",1,-1,1)
 Str = Replace(Str,"<","&lt;",1,-1,1)
 Str = Replace(Str,">","&gt;",1,-1,1)
 Str = Replace(Str,"script","&#115;cript",1,-1,0)
 Str = Replace(Str,"SCRIPT","&#083;CRIPT",1,-1,0)
 Str = Replace(Str,"Script","&#083;cript",1,-1,0)
 Str = Replace(Str,"script","&#083;cript",1,-1,1)
 Str = Replace(Str,"object","&#111;bject",1,-1,0)
 Str = Replace(Str,"OBJECT","&#079;BJECT",1,-1,0)
 Str = Replace(Str,"Object","&#079;bject",1,-1,0)
 Str = Replace(Str,"object","&#079;bject",1,-1,1)
 Str = Replace(Str,"applet","&#097;pplet",1,-1,0)
 Str = Replace(Str,"APPLET","&#065;PPLET",1,-1,0)
 Str = Replace(Str,"Applet","&#065;pplet",1,-1,0)
 Str = Replace(Str,"applet","&#065;pplet",1,-1,1)
 Str = Replace(Str,"[","&#091;")
 Str = Replace(Str,"]","&#093;")
 Str = Replace(Str,"""","",1,-1,1)
 Str = Replace(Str,"=","&#061;",1,-1,1)
 Str = Replace(Str,"'","''",1,-1,1)
 Str = Replace(Str,"select","sel&#101;ct",1,-1,1)
 Str = Replace(Str,"execute","&#101xecute",1,-1,1)
 Str = Replace(Str,"exec","&#101xec",1,-1,1)
 Str = Replace(Str,"join","jo&#105;n",1,-1,1)
 Str = Replace(Str,"union","un&#105;on",1,-1,1)
 Str = Replace(Str,"where","wh&#101;re",1,-1,1)
 Str = Replace(Str,"insert","ins&#101;rt",1,-1,1)
 Str = Replace(Str,"delete","del&#101;te",1,-1,1)
 Str = Replace(Str,"update","up&#100;ate",1,-1,1)
 Str = Replace(Str,"like","lik&#101;",1,-1,1)
 Str = Replace(Str,"drop","dro&#112;",1,-1,1)
 Str = Replace(Str,"create","cr&#101;ate",1,-1,1)
 Str = Replace(Str,"rename","ren&#097;me",1,-1,1)
 Str = Replace(Str,"count","co&#117;nt",1,-1,1)
 Str = Replace(Str,"chr","c&#104;r",1,-1,1)
 Str = Replace(Str,"mid","m&#105;d",1,-1,1)
 Str = Replace(Str,"truncate","trunc&#097;te",1,-1,1)
 Str = Replace(Str,"nchar","nch&#097;r",1,-1,1)
 Str = Replace(Str,"char","ch&#097;r",1,-1,1)
 Str = Replace(Str,"alter","alt&#101;r",1,-1,1)
 Str = Replace(Str,"cast","ca&#115;t",1,-1,1)
 Str = Replace(Str,"exists","e&#120;ists",1,-1,1)
 Filterstr = Replace(Str,"'","''",1,-1,1)
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, "&", "&amp;")
    Str = Replace(Str,"'","&#39;")
    Str = Replace(Str,"""","&#34;")
 Dim re
 Set re=new RegExp
 re.IgnoreCase =True
 re.Global=True
 re.Pattern="(w)(here)"
    Str = re.replace(Str,"$1h&#101;re")
 re.Pattern="(s)(elect)"
    Str = re.replace(Str,"$1el&#101;ct")
 re.Pattern="(i)(nsert)"
    Str = re.replace(Str,"$1ns&#101;rt")
 re.Pattern="(c)(reate)"
    Str = re.replace(Str,"$1r&#101;ate")
 re.Pattern="(d)(rop)"
    Str = re.replace(Str,"$1ro&#112;")
 re.Pattern="(a)(lter)"
    Str = re.replace(Str,"$1lt&#101;r")
 re.Pattern="(d)(elete)"
    Str = re.replace(Str,"$1el&#101;te")
 re.Pattern="(u)(pdate)"
    Str = re.replace(Str,"$1p&#100;ate")
 re.Pattern="(/s)(or)"
    Str = re.replace(Str,"$1o&#114;")
 Set re=Nothing
 CheckStr=Str
End Function
'*************************************
'恢复特殊字符
'*************************************
Function UnCheckStr(ByVal Str)
 If IsNull(Str) Then
  UnCheckStr = ""
  Exit Function
 End If
     Str = Replace(Str,"&#39;","'")
        Str = Replace(Str,"&#34;","""")
  Dim re
  Set re=new RegExp
  re.IgnoreCase =True
  re.Global=True
  re.Pattern="(w)(h&#101;re)"
     str = re.replace(str,"$1here")
  re.Pattern="(s)(el&#101;ct)"
     str = re.replace(str,"$1elect")
  re.Pattern="(i)(ns&#101;rt)"
     str = re.replace(str,"$1nsert")
  re.Pattern="(c)(r&#101;ate)"
     str = re.replace(str,"$1reate")
  re.Pattern="(d)(ro&#112;)"
     str = re.replace(str,"$1rop")
  re.Pattern="(a)(lt&#101;r)"
     str = re.replace(str,"$1lter")
  re.Pattern="(d)(el&#101;te)"
     str = re.replace(str,"$1elete")
  re.Pattern="(u)(p&#100;ate)"
     str = re.replace(str,"$1pdate")
  re.Pattern="(/s)(o&#114;)"
     Str = re.replace(Str,"$1or")
  Set re=Nothing
        Str = Replace(Str, "&amp;", "&")
     UnCheckStr=Str
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
'*************************************
'获取客户端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
'*************************************
'图片添加水印函数
'*************************************
sub setWatermark(picFile,stampFile)
 on error resume next
 if CheckObjInstalled("Persits.Jpeg")=true then
  Set stamp = Server.CreateObject("Persits.Jpeg")
  stampFile = Server.MapPath(stampFile)
  stamp.Open stampFile
  Set Photo = Server.CreateObject("Persits.Jpeg")
  picFile = Server.MapPath(picFile)
  Photo.Open picFile
  wh=Photo.width/2-stamp.Width/2
  ht=Photo.height/2-stamp.Height/2
  Photo.DrawImage wh,1,stamp,0.2,&HFFFFFF
  Photo.Save picFile
  set stamp=nothing
  set Photo=nothing
 else
  response.Write "服务器不支持Persits.Jpeg组件，水印添加失败。同时，可能导致本网站很多主要功能不能使用，请为服务器安装Persits.Jpeg组件。"
  exit sub
 end if
end sub
'*************************************
'制作图片缩略图函数
'*************************************
sub createMiniPic(picFile,miniFile,miniWidth,miniHeight)
 on error resume next
 if CheckObjInstalled("Persits.Jpeg")=true then
  Response.Expires = 0
  Set Jpeg = Server.CreateObject("Persits.Jpeg")
  Jpeg.Open(server.mappath(picFile))
  'orgWidth=Jpeg.OriginalWidth
  'orgheight=Jpeg.OriginalHeight
  'scale=orgWidth/orgheight
  'width=miniHeight*scale
  'if width>miniWidth then width=miniWidth
  Jpeg.Width = miniWidth
  Jpeg.Height = miniHeight
  Jpeg.Save server.mappath(miniFile)
  set Jpeg=nothing
 else
  response.Write "服务器不支持Persits.Jpeg组件，水印添加失败。同时，可能导致本网站很多主要功能不能使用，请为服务器安装Persits.Jpeg组件。"
  exit sub
 end if
end sub

'*************************************
'***二进制数据转化为字符串函数
'*************************************
Function Bytes2bStr(vin)
 if lenb(vin) =0 then
  Bytes2bStr = ""
  exit function
 end if
 ''二进制转换为字符串
 Dim BytesStream,StringReturn
 set BytesStream = Server.CreateObject("ADODB.Stream")
 BytesStream.Type = 2
 BytesStream.Open
 BytesStream.WriteText vin
 BytesStream.Position = 0
 BytesStream.Charset = "gb2312"
 BytesStream.Position = 2
 StringReturn = BytesStream.ReadText
 BytesStream.close
 set BytesStream = Nothing
 Bytes2bStr = StringReturn
End Function
'*************************************
'***enctype="multipart/form-data"的表
'单数据的文本数据提取函数
'*************************************
Function Myrequest(fldname)
 ''取表单数据，支持对同名表单域的读取
 dim i,fldHead,tmpvalue
 for i = 0 to loopcnt-1
  fldHead = fldInfo(i,0)
  if instr(lcase(fldHead),lcase(fldname))>0 then
   ''表单在数组中，判断该表单域内容
   tmpvalue = FldInfo(i,1)
   if instr(fldHead,"filename=""")<1 then
    Tmpvalue = Bytes2bStr(tmpvalue)
    if myrequest <> "" then
     myrequest = myrequest & "," &tmpvalue
    else
     MyRequest = tmpvalue
    end if   
   else
    myrequest = tmpvalue
   end if   
  end if
 next
End function
'*************************************
'***获取上传表单原上传文件文件名
'*************************************
Function GetFileName(fldName)
 ''都取原上传文件文件名
 dim i,fldHead,fnpos
 for i = 0 to loopcnt-1
  fldHead = lcase(fldInfo(i,0))
  if instr(fldHead,lcase(fldName)) > 0 then
   fnpos = instr(fldHead,"filename=""")
   if fnpos < 1 then exit for
   fldHead = mid(fldHead,fnpos+10)
   ''表单内容
   GetFileName = mid(fldHead,1,instr(fldHead,"""")-1)
   GetfileName = mid(GetFileName,instrRev(GetFileName,"/")+1)
  end if
 next
End function
'*************************************
'获取上传表单原上传文件的类型，限定读
'取文件域的内容
'*************************************
Function GetContentType(fldName)
 dim i
 dim fldHead,cpos
 for i = 0 to loopcnt - 1
  fldHead = lcase(fldInfo(i,0))
  if instr(fldHead,lcase(fldName)) > 0 and instr(fldHead,"filename=""") >0 then
   cpos = instr(fldHead,"content-type: ")
   GetContentType = mid(fldHead,cpos+14)
  end if
 next
End function
'*************************************
'***获取上传表单原上传文件扩展名
'*************************************
Function GetFileTypeName(Fldname)
 If instr(Fldname,".") > 0 Then
  GetFileTypeName = right(Fldname,3)
 End If
End Function
'*************************************
'***'限制上传文件类型
'*************************************
Function IsvalidFile(FileType)
 If instr(PicType,FileType)=0 then
  IsvalidFile = false
 Else
  IsvalidFile = true
 End if
End Function

'------------------------------------------------
'FilterJS(strHTML)
'过滤脚本
'------------------------------------------------
Function FilterJS(byval strHTML)
 Dim objReg,strContent 
 If IsNull(strHTML) OR strHTML="" Then Exit Function 
  
 Set objReg=New RegExp
 objReg.IgnoreCase =True
 objReg.Global=True
 objReg.Pattern="(&#)"
 strContent=objReg.Replace(strHTML,"")
 objReg.Pattern="(function|meta|value|window/.|script|js:|about:|file:|Document/.|vbs:|frame|cookie)"
 strContent=objReg.Replace(strContent,"")
 objReg.Pattern="(on(finish|mouse|Exit=|error|click|key|load|focus|Blur))"
 strContent=objReg.Replace(strContent,"")
 FilterJS=strContent
 strContent=""
 Set objReg=Nothing 
End Function
'------------------------------------------------
'CheckInt(byval strNumber)
'检查并转换整形值
'------------------------------------------------
Function CheckInt(byval strNumber)
 If isNull(strNumber) OR Not IsNumeric(strNumber) Then
  CheckInt="" 
 Else
  CheckInt=CLNG(strNumber)
 End If
End Function
'获取访问者IP
Function GetIP()
    Dim strIPAddr
    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 = ProtectSQL(Trim(Mid(strIPAddr, 1, 30)))
End Function
%>
 
Tony088
关注
评论
添加红包

请填写红包祝福语或标题

个

红包个数最小为10个

元

红包金额最低5元

当前余额3.43元 前往充值 >
需支付：10.00元
成就一亿技术人!
领取后你会自动成为博主和红包主的粉丝 规则
hope_wisdom
发出的红包
实付元
使用余额支付
点击重新获取
扫码支付
钱包余额 0

抵扣说明：

1.余额是钱包充值的虚拟货币，按照1:1的比例进行支付金额的抵扣。
2.余额无法直接购买下载，可以购买VIP、付费专栏及课程。

余额充值