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

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