ASP常用函数大收集01[大部分来自网络]
2007-11-23 16:24
627 查看
<%
'*************************************
'防止外部提交
'*************************************
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,"$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
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, ">", ">")
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
'*************************************
'计算随机数
'*************************************
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,"""",""",1,-1,1)
Str = Replace(Str,"<","<",1,-1,1)
Str = Replace(Str,">",">",1,-1,1)
Str = Replace(Str,"script","script",1,-1,0)
Str = Replace(Str,"SCRIPT","SCRIPT",1,-1,0)
Str = Replace(Str,"Script","Script",1,-1,0)
Str = Replace(Str,"script","Script",1,-1,1)
Str = Replace(Str,"object","object",1,-1,0)
Str = Replace(Str,"OBJECT","OBJECT",1,-1,0)
Str = Replace(Str,"Object","Object",1,-1,0)
Str = Replace(Str,"object","Object",1,-1,1)
Str = Replace(Str,"applet","applet",1,-1,0)
Str = Replace(Str,"APPLET","APPLET",1,-1,0)
Str = Replace(Str,"Applet","Applet",1,-1,0)
Str = Replace(Str,"applet","Applet",1,-1,1)
Str = Replace(Str,"[","[")
Str = Replace(Str,"]","]")
Str = Replace(Str,"""","",1,-1,1)
Str = Replace(Str,"=","=",1,-1,1)
Str = Replace(Str,"'","''",1,-1,1)
Str = Replace(Str,"select","select",1,-1,1)
Str = Replace(Str,"execute","execute",1,-1,1)
Str = Replace(Str,"exec","exec",1,-1,1)
Str = Replace(Str,"join","join",1,-1,1)
Str = Replace(Str,"union","union",1,-1,1)
Str = Replace(Str,"where","where",1,-1,1)
Str = Replace(Str,"insert","insert",1,-1,1)
Str = Replace(Str,"delete","delete",1,-1,1)
Str = Replace(Str,"update","update",1,-1,1)
Str = Replace(Str,"like","like",1,-1,1)
Str = Replace(Str,"drop","drop",1,-1,1)
Str = Replace(Str,"create","create",1,-1,1)
Str = Replace(Str,"rename","rename",1,-1,1)
Str = Replace(Str,"count","count",1,-1,1)
Str = Replace(Str,"chr","chr",1,-1,1)
Str = Replace(Str,"mid","mid",1,-1,1)
Str = Replace(Str,"truncate","truncate",1,-1,1)
Str = Replace(Str,"nchar","nchar",1,-1,1)
Str = Replace(Str,"char","char",1,-1,1)
Str = Replace(Str,"alter","alter",1,-1,1)
Str = Replace(Str,"cast","cast",1,-1,1)
Str = Replace(Str,"exists","exists",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, "&", "&")
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 UnCheckStr(ByVal Str)
If IsNull(Str) Then
UnCheckStr = ""
Exit Function
End If
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
Str = Replace(Str, "&", "&")
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
%>
'*************************************
'防止外部提交
'*************************************
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,"$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
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, ">", ">")
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
'*************************************
'计算随机数
'*************************************
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,"""",""",1,-1,1)
Str = Replace(Str,"<","<",1,-1,1)
Str = Replace(Str,">",">",1,-1,1)
Str = Replace(Str,"script","script",1,-1,0)
Str = Replace(Str,"SCRIPT","SCRIPT",1,-1,0)
Str = Replace(Str,"Script","Script",1,-1,0)
Str = Replace(Str,"script","Script",1,-1,1)
Str = Replace(Str,"object","object",1,-1,0)
Str = Replace(Str,"OBJECT","OBJECT",1,-1,0)
Str = Replace(Str,"Object","Object",1,-1,0)
Str = Replace(Str,"object","Object",1,-1,1)
Str = Replace(Str,"applet","applet",1,-1,0)
Str = Replace(Str,"APPLET","APPLET",1,-1,0)
Str = Replace(Str,"Applet","Applet",1,-1,0)
Str = Replace(Str,"applet","Applet",1,-1,1)
Str = Replace(Str,"[","[")
Str = Replace(Str,"]","]")
Str = Replace(Str,"""","",1,-1,1)
Str = Replace(Str,"=","=",1,-1,1)
Str = Replace(Str,"'","''",1,-1,1)
Str = Replace(Str,"select","select",1,-1,1)
Str = Replace(Str,"execute","execute",1,-1,1)
Str = Replace(Str,"exec","exec",1,-1,1)
Str = Replace(Str,"join","join",1,-1,1)
Str = Replace(Str,"union","union",1,-1,1)
Str = Replace(Str,"where","where",1,-1,1)
Str = Replace(Str,"insert","insert",1,-1,1)
Str = Replace(Str,"delete","delete",1,-1,1)
Str = Replace(Str,"update","update",1,-1,1)
Str = Replace(Str,"like","like",1,-1,1)
Str = Replace(Str,"drop","drop",1,-1,1)
Str = Replace(Str,"create","create",1,-1,1)
Str = Replace(Str,"rename","rename",1,-1,1)
Str = Replace(Str,"count","count",1,-1,1)
Str = Replace(Str,"chr","chr",1,-1,1)
Str = Replace(Str,"mid","mid",1,-1,1)
Str = Replace(Str,"truncate","truncate",1,-1,1)
Str = Replace(Str,"nchar","nchar",1,-1,1)
Str = Replace(Str,"char","char",1,-1,1)
Str = Replace(Str,"alter","alter",1,-1,1)
Str = Replace(Str,"cast","cast",1,-1,1)
Str = Replace(Str,"exists","exists",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, "&", "&")
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 UnCheckStr(ByVal Str)
If IsNull(Str) Then
UnCheckStr = ""
Exit Function
End If
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
Str = Replace(Str, "&", "&")
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
%>
内容来自用户分享和网络整理，不保证内容的准确性，如有侵权内容，可联系管理员处理 
相关文章推荐
- Struts快速学习指南01(内部培训教材)-大部分素材来自于《Programming Jakarta Struts》一书
- Java中需要理解的问题----收集来自网络
- 关于JS中，怎么绑定this对象（来自网络收集整理）
- 网络资源收集(01/15/2007-01/19/2007)
- 收集整理来自网络上的一些常见的 前端、H5面试题 前端开发面试题
- Apple iOS XCode 收集来自网络
- web 开发中的各种页面的提交请求数据方法汇总(持续更新，内容收集来自各网络)
- 关于一些TCP IP协议的解释ps：来自于网络的收集
- Write,writeline,WriteString函数(来自网络,全是粘贴,收集自己用)
- 可借鉴的C++爬虫范本---来自网络收集
- [导入]VI 的小技巧收集(多数来自网络)
- 网络资源收集工具概要设计文档
- 17 - 01 - 20 计算机网络（10）（IP地址分配）
- 第01天多线程网络:(01):进程和线程
- FC网络学习笔记01 分类： 网络基础 2013-10-10 09:42 865人阅读 评论(0) 收藏
- 收集的网络上大型的开源图像处理软件代码（提供下载链接)
- Android权限使用(网络收集的资料)
- 收集的网络上大型的开源图像处理软件代码（提供下载链接)
- IOS开发之2-----网络请求01
- UA-tester收集网络服务信息