【www.bbyears.com--php常用代码】
简单实例一
这里可用到xmlhttp 和文件对象 fso,
代码如下<%
Function SaveRemoteFile(sSavePath,sRemoteFileUrl)
On Error Resume Next
SaveRemoteFile = False
Dim oXML : Set oXML = Server.CreateObject("Microsoft.XMLHTTP")
With oXML
.Open "Get",sRemoteFileUrl,False,"",""
.Send
If .Status<>200 Then Exit Function
RemoteDate = .ResponseBody
End With
Set oXML = Nothing
Dim oStream : Set oStream = Server.CreateObject("Adodb.Stream")
With oStream
.Type = 1
.Open
.Write RemoteDate
.SaveToFile sSavePath,2
If Err.Number=0 Then SaveRemoteFile = True
.Close()
End With
Set oStream = Nothing
End Function"调用方法如下
SaveAddr=Server.MapPath("demo.gif")
SourceURL="http://www.google.cn/intl/zh-CN/images/logo_cn.gif"
Call SaveRemoteFile(SaveAddr,SourceURL)
%>
实例1把图片保存到本地然后生成缩略图
ASP通过XMLHTTP获取远程图片流数据,并保存到本地,把第一张采集到的图片生成缩略图。
具体代码如下:
代码如下<%
"==================================================
"函数名:CheckDir2
"作 用:检查文件夹是否存在
"参 数:FolderPath ------文件夹地址
"==================================================
Function CheckDir2(byval FolderPath)
dim fso
folderpath=Server.MapPath(".")&""&folderpath
Set fso = Server.CreateObject("Scripting.FileSystemObject")
If fso.FolderExists(FolderPath) then
"存在
CheckDir2 = True
Else
"不存在
CheckDir2 = False
End if
Set fso = nothing
End Function
"==================================================
"函数名:MakeNewsDir2
"作 用:创建新的文件夹
"参 数:foldername ------文件夹名称
"==================================================
Function MakeNewsDir2(byval foldername)
dim fso
Set fso = Server.CreateObject("Scripting.FileSystemObject")
fso.CreateFolder(Server.MapPath(".") &"" &foldername)
If fso.FolderExists(Server.MapPath(".") &"" &foldername) Then
MakeNewsDir2 = True
Else
MakeNewsDir2 = False
End If
Set fso = nothing
End Function
"==================================================
"函数名:DefiniteUrl
"作 用:将相对地址转换为绝对地址
"参 数:PrimitiveUrl ------要转换的相对地址
"参 数:ConsultUrl ------当前网页地址
"==================================================
Function DefiniteUrl(Byval PrimitiveUrl,Byval ConsultUrl)
Dim ConTemp,PriTemp,Pi,Ci,PriArray,ConArray
If PrimitiveUrl="" or ConsultUrl="" or PrimitiveUrl="$False$" Then
DefiniteUrl="$False$"
Exit Function
End If
If Left(ConsultUrl,7)<>"HTTP://" And Left(ConsultUrl,7)<>"http://" Then
ConsultUrl= "http://" & ConsultUrl
End If
ConsultUrl=Replace(ConsultUrl,"://",":\")
If Right(ConsultUrl,1)<>"/" Then
If Instr(ConsultUrl,"/")>0 Then
If Instr(Right(ConsultUrl,Len(ConsultUrl)-InstrRev(ConsultUrl,"/")),".")>0 then
Else
ConsultUrl=ConsultUrl & "/"
End If
Else
ConsultUrl=ConsultUrl & "/"
End If
End If
ConArray=Split(ConsultUrl,"/")
If Left(PrimitiveUrl,7) = "http://" then
DefiniteUrl=Replace(PrimitiveUrl,"://",":\")
ElseIf Left(PrimitiveUrl,1) = "/" Then
DefiniteUrl=ConArray(0) & PrimitiveUrl
ElseIf Left(PrimitiveUrl,2)="./" Then
DefiniteUrl=ConArray(0) & Right(PrimitiveUrl,Len(PrimitiveUrl)-1)
ElseIf Left(PrimitiveUrl,3)="../" then
Do While Left(PrimitiveUrl,3)="../"
PrimitiveUrl=Right(PrimitiveUrl,Len(PrimitiveUrl)-3)
Pi=Pi+1
Loop
For Ci=0 to (Ubound(ConArray)-1-Pi)
If DefiniteUrl<>"" Then
DefiniteUrl=DefiniteUrl & "/" & ConArray(Ci)
Else
DefiniteUrl=ConArray(Ci)
End If
Next
DefiniteUrl=DefiniteUrl & "/" & PrimitiveUrl
Else
If Instr(PrimitiveUrl,"/")>0 Then
PriArray=Split(PrimitiveUrl,"/")
If Instr(PriArray(0),".")>0 Then
If Right(PrimitiveUrl,1)="/" Then
DefiniteUrl="http:\" & PrimitiveUrl
Else
If Instr(PriArray(Ubound(PriArray)-1),".")>0 Then
DefiniteUrl="http:\" & PrimitiveUrl
Else
DefiniteUrl="http:\" & PrimitiveUrl & "/"
End If
End If
Else
If Right(ConsultUrl,1)="/" Then
DefiniteUrl=ConsultUrl & PrimitiveUrl
Else
DefiniteUrl=Left(ConsultUrl,InstrRev(ConsultUrl,"/")) & PrimitiveUrl
End If
End If
Else
If Instr(PrimitiveUrl,".")>0 Then
If Right(ConsultUrl,1)="/" Then
If right(PrimitiveUrl,3)=".cn" or right(PrimitiveUrl,3)="com" or right(PrimitiveUrl,3)="net" or right(PrimitiveUrl,3)="org" Then
DefiniteUrl="http:\" & PrimitiveUrl & "/"
Else
DefiniteUrl=ConsultUrl & PrimitiveUrl
End If
Else
If right(PrimitiveUrl,3)=".cn" or right(PrimitiveUrl,3)="com" or right(PrimitiveUrl,3)="net" or right(PrimitiveUrl,3)="org" Then
DefiniteUrl="http:\" & PrimitiveUrl & "/"
Else
DefiniteUrl=Left(ConsultUrl,InstrRev(ConsultUrl,"/")) & "/" & PrimitiveUrl
End If
End If
Else
If Right(ConsultUrl,1)="/" Then
DefiniteUrl=ConsultUrl & PrimitiveUrl & "/"
Else
DefiniteUrl=Left(ConsultUrl,InstrRev(ConsultUrl,"/")) & "/" & PrimitiveUrl & "/"
End If
End If
End If
End If
If Left(DefiniteUrl,1)="/" then
DefiniteUrl=Right(DefiniteUrl,Len(DefiniteUrl)-1)
End if
If DefiniteUrl<>"" Then
DefiniteUrl=Replace(DefiniteUrl,"//","/")
DefiniteUrl=Replace(DefiniteUrl,":\","://")
Else
DefiniteUrl="$False$"
End If
End Function
"==================================================
"函数名:ReplaceSaveRemoteFile
"作 用:替换、保存远程文件
"参 数:ConStr ------ 要替换的字符串
"参 数:StarStr ----- 前导
"参 数:OverStr -----
"参 数:IncluL ------
"参 数:IncluR ------
"参 数:SaveTf ------ 是否保存文件,False不保存,True保存
"参 数:SaveFilePath- 保存文件夹
"参 数: TistUrl------ 当前网页地址
"==================================================
Function ReplaceSaveRemoteFile(ConStr,StartStr,OverStr,IncluL,IncluR,SaveTf,SaveFilePath,TistUrl)
If ConStr="$False$" or ConStr="" Then
ReplaceSaveRemoteFile="$False$"
Exit Function
End If
Dim TempStr,TempStr2,ReF,Matches,Match,Tempi,TempArray,TempArray2,OverTypeArray
Set ReF = New Regexp
ReF.IgnoreCase = True
ReF.Global = True
ReF.Pattern = "("&StartStr&").+?("&OverStr&")"
Set Matches =ReF.Execute(ConStr)
For Each Match in Matches
If Instr(TempStr,Match.Value)=0 Then
If TempStr<>"" then
TempStr=TempStr & "$Array$" & Match.Value
Else
TempStr=Match.Value
End if
End If
Next
Set Matches=nothing
Set ReF=nothing
If TempStr="" or IsNull(TempStr)=True Then
ReplaceSaveRemoteFile=ConStr
Exit function
End if
If IncluL=False then
TempStr=Replace(TempStr,StartStr,"")
End if
If IncluR=False then
If Instr(OverStr,"|")>0 Then
OverTypeArray=Split(OverStr,"|")
For Tempi=0 To Ubound(OverTypeArray)
TempStr=Replace(TempStr,OverTypeArray(Tempi),"")
Next
Else
TempStr=Replace(TempStr,OverStr,"")
End If
End if
TempStr=Replace(TempStr,"""","")
TempStr=Replace(TempStr,""","")
Dim RemoteFile,RemoteFileurl,SaveFileName,SaveFileType,ArrSaveFileName,RanNum
If Right(SaveFilePath,1)="/" then
SaveFilePath=Left(SaveFilePath,Len(SaveFilePath)-1)
End If
If SaveTf=True then
If CheckDir2(SaveFilePath)=False Then
If MakeNewsDir2(SaveFilePath)=False Then
SaveTf=False
End If
End If
End If
SaveFilePath=SaveFilePath & "/"
"图片转换/保存
TempArray=Split(TempStr,"$Array$")
For Tempi=0 To Ubound(TempArray)
RemoteFileurl=DefiniteUrl(TempArray(Tempi),TistUrl)
If RemoteFileurl<>"$False$" And SaveTf=True Then"保存图片
ArrSaveFileName = Split(RemoteFileurl,".")
SaveFileType=ArrSaveFileName(Ubound(ArrSaveFileName))"文件类型
RanNum=Int(900*Rnd)+100
SaveFileName = SaveFilePath&year(now)&month(now)&day(now)&hour(now)&minute(now)&second(now)&ranNum&"."&SaveFileType
Call SaveRemoteFile(SaveFileName,RemoteFileurl)
ConStr=Replace(ConStr,TempArray(Tempi),SaveFileName)
ElseIf RemoteFileurl<>"$False$" and SaveTf=False Then"不保存图片
SaveFileName=RemoteFileUrl
ConStr=Replace(ConStr,TempArray(Tempi),SaveFileName)
End If
If RemoteFileUrl<>"$False$" Then
If UploadFiles="" then
UploadFiles=SaveFileName
Else
UploadFiles=UploadFiles & "|" & SaveFileName
End if
End If
Next
ReplaceSaveRemoteFile=ConStr
End function
"==================================================
"过程名:SaveRemoteFile
"作 用:保存远程的文件到本地
"参 数:LocalFileName ------ 本地文件名
"参 数:RemoteFileUrl ------ 远程文件URL
"==================================================
sub SaveRemoteFile(LocalFileName,RemoteFileUrl)
dim Ads,Retrieval,GetRemoteData
Set Retrieval = Server.CreateObject("Microsoft.XMLHTTP")
With Retrieval
.Open "Get", RemoteFileUrl, False, "", ""
.Send
GetRemoteData = .ResponseBody
End With
Set Retrieval = Nothing
Set Ads = Server.CreateObject("Adodb.Stream")
With Ads
.Type = 1
.Open
.Write GetRemoteData
.SaveToFile server.MapPath(LocalFileName),2
.Cancel()
.Close()
End With
Set Ads=nothing
end sub
"==================================================
"过程名:GetImg
"作 用:取得文章中第一张图片
"参 数:str ------ 文章内容
"参 数:strpath ------ 保存图片的路径
"==================================================
Function GetImg(str,strpath)
set objregEx = new RegExp
objregEx.IgnoreCase = true
objregEx.Global = true
zzstr=""&strpath&"(.+?).(jpg|gif|png|bmp)"
objregEx.Pattern = zzstr
set matches = objregEx.execute(str)
for each match in matches
retstr = retstr &"|"& Match.Value
next
if retstr<>"" then
Imglist=split(retstr,"|")
Imgone=replace(Imglist(1),strpath,"")
GetImg=Imgone
else
GetImg=""
end if
end function
%>
例:
程序代码
<%
if request.QueryString("action")="test" then
"图片开始的字符串
FilesStartStr="src="
"图片结束的字符串
FilesOverStr="gif|jpg|bmp"
"保存图片的文件夹
FilesPath="qq"
"取得保存图片的网站URL 自动判断是绝对 还是相对路径
NewsUrl="http://news.163.com"
"取得文章内容
Content =Request.Form("body")
"开始保存图片
Content=ReplaceSaveRemoteFile(Content,FilesStartStr,FilesOverStr,False,True,True,FilesPath,NewsUrl)
"对新闻中的第一张图片创建缩略图
if GetImg(Content,FilesPath)<>"" then
Imgsrc=GetImg(Content,FilesPath)
Imgsrc=replace(Imgsrc,FilesPath,"")
Set Jpeg = Server.CreateObject("Persits.Jpeg")
Path = Server.MapPath(""&FilesPath&"") & ""&Imgsrc&""
Jpeg.Open Path
"如果图片宽小于等于120 高小于等于90 则不创建缩略图
if Jpeg.OriginalWidth<=120 and Jpeg.Height<=90 then
Jpeg.Width = Jpeg.OriginalWidth
Jpeg.Height = Jpeg.OriginalHeight
Smallimg=FilesPath&""&GetImg(Content,FilesPath)
else
"图片宽度高度/2
Jpeg.Width = Jpeg.OriginalWidth / 2
Jpeg.Height = Jpeg.OriginalHeight / 2
Jpeg.Save Server.MapPath(""&FilesPath&"") & "small_"&Imgsrc&""
Smallimg=""&FilesPath&"/small_"&Imgsrc&""
end if
end if
"显示结果
response.Write("新闻中的第一张图片是:")
response.Write("")
response.Write("
新闻中的第一张图片的缩略图是:")
response.Write("")
response.Write("
新的新闻内容(图片为本地):
")
Response.Write(Content)
Response.End()
end if
%>
注:如果有些网防盗连这时图片不能保存了,我们需要模仿ie浏览器发布信息以用户正常浏览模式去下载,代码如
代码如下
<%
"盗链判断
Dim server_v1,server_v2
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
Response.Write "非法的盗链"
Response.End
End If
Dim url, body, myCache
url = Request.QueryString("url")
Set myCache = new cache
myCache.name = "picindex"&url
If myCache.valid Then
body = myCache.value
Else
body = GetWebData(url)
myCache.add body,dateadd("d",1,now)
End If
If Err.Number = 0 Then
Response.CharSet = "UTF-8"
Response.ContentType = "application/octet-stream"
Response.BinaryWrite body
Response.Flush
Else
Wscript.Echo Err.Description
End if
"取得数据
Public Function GetWebData(ByVal strUrl)
Dim curlpath
curlpath = Mid(strUrl,1,Instr(8,strUrl,"/"))
Dim Retrieval
Set Retrieval = Server.CreateObject("Microsoft.XMLHTTP")
With Retrieval
.Open "Get", strUrl, False,"",""
.setRequestHeader "Referer", curlpath
.Send
GetWebData =.ResponseBody
End With
Set Retrieval = Nothing
End Function
"cache类
class Cache
private obj "cache内容
private expireTime "过期时间
private expireTimeName "过期时间application名
private cacheName "cache内容application名
private path "url
private sub class_initialize()
path=request.servervariables("url")
path=left(path,instrRev(path,"/"))
end sub
private sub class_terminate()
end sub
public property get blEmpty
"是否为空
if isempty(obj) then
blEmpty=true
else
blEmpty=false
end if
end property
public property get valid
"是否可用(过期)
if isempty(obj) or not isDate(expireTime) then
valid=false
elseif CDate(expireTime)
else
valid=true
end if
end property
public property let name(str)
"设置cache名
cacheName=str & path
obj=application(cacheName)
expireTimeName=str & "expires" & path
expireTime=application(expireTimeName)
end property
public property let expires™
"重设置过期时间
expireTime=tm
application.lock
application(expireTimeName)=expireTime
application.unlock
end property
public sub add(var,expire)
"赋值
if isempty(var) or not isDate(expire) then
exit sub
end if
obj=var
expireTime=expire
application.lock
application(cacheName)=obj
application(expireTimeName)=expireTime
application.unlock
end sub
public property get value
"取值
if isempty(obj) or not isDate(expireTime) then
value=null
elseif CDate(expireTime)
else
value=obj
end if
end property
public sub makeEmpty()
"释放application
application.lock
application(cacheName)=empty
application(expireTimeName)=empty
application.unlock
obj=empty
expireTime=empty
end sub
public function equal(var2)
"比较
if typename(obj)<>typename(var2) then
equal=false
elseif typename(obj)="Object" then
if obj is var2 then
equal=true
else
equal=false
end if
elseif typename(obj)="Variant()" then
if join(obj,"^")=join(var2,"^") then
equal=true
else
equal=false
end if
else
if obj=var2 then
equal=true
else
equal=false
end if
end if
end function
end class
%>
这些代码可以有效的破解图片防盗链系统.如网易相册.直接把下面的代码保存成pic.asp,然后用pic.asp?url=图片路径的方式调用即可.增加了缓存技术