ASP保存远程图片到本地 同时取得第一张图片并创建缩略图的代码

采集中 或者 在线添加文章中 都可以用到此功能

俺自己在baidu上搜索的保存远程图片到本地的代码 感觉比较难用点 而且没有现成的比较全的代码 俺也看不懂

俺从 SNA新闻采集系统 For 3.62 (程序制作:ansir)里提取了点函数 用下 比较简单好用
以下是函数

程序代码

<％ 
'================================================== 
'函数名：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="https://img.aspxhome.com/file/UploadPic/20112/5/201125111856167.jpg" width="240" border="0" /> 
<img class="left"src="https://img.aspxhome.com/file/UploadPic/20112/5/201125111856249.gif" width="114" /> 
<img height="60" src="https://img.aspxhome.com/file/UploadPic/20112/5/201125111857901.jpg" width="120" border="0" /> 
<img height="60" alt="中国维和人数大国之首" src="https://img.aspxhome.com/file/UploadPic/20112/5/201125111857510.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 
％>