获取远程图片并保存到本地
 内容

<%
'==================================================
'函数名: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
%>

以下是 例子
程序代码
<form id="form1" name="form1" method="post" action="?action=test">
  <textarea name="body" cols="50" rows="5" id="body">
<img height="180" src="http://cimg2.163.com/cnews/2006/8/21/200608210738371d0a8.jpg" width="240" border="0" />
<img class="left"src="http://news.163.com/img/netease_logo.gif" width="114" />
<img height="60" src="http://cimg2.163.com/cnews/2006/8/18/2006081811465369976.jpg" width="120" border="0" />
<img height="60" alt="中国维和人数大国之首" src="http://cimg2.163.com/cnews/2006/8/18/200608181506554fd8f.jpg" width="120" border="0" />
  </textarea>
  <input type="submit" name="Submit" value="提交" />
</form>
<%
if request.QueryString("action")="test" then
'图片开始的字符串
FilesStartStr="src="
'图片结束的字符串
FilesOverStr="gif|jpg|bmp"
'保存图片的文件夹
FilesPath="qq"
'取得保存图片的网站URL 自动判断是绝对 还是相对路径 该例子中图片是绝对地址 所以NEWURL等于没用 如果是../images /123.gif这样的 就需要指定NEWURL了
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("<img src="&FilesPath&"/"&GetImg(Content,FilesPath)&">")
response.Write("<br>新闻中的第一张图片的缩略图是:")
response.Write("<img src="&Smallimg&">")
response.Write("<br>新的新闻内容(图片为本地):<br>")
Response.Write(Content)
Response.End()
end if
%>

::+::文摘来源于互联网,其观点仅代表作者本人观点,与本站立场无关,如果侵害到你的权益,请联系本站删除::+::知识产权保护::+::要捐助本站么::+::
::+::推广服务说明:如果你的网站是正规的站点,或你的商品是合格的产品,随时欢迎与我们联络,本站联系电话:13695067571::+::要推广服务么::+::