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 

%> 

例: 

程序代码 

<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 自动判断是绝对 还是相对路径 

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 

%>