作家
登录

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

作者: 来源:www.28hudong.com 2013-03-30 08:26:50 阅读 我要评论

采集中 或者 在线添加文章中 都可以用到此功能 俺自己在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="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 %>

  推荐阅读

  Ajax+asp应用实例 注册模块,表单提交

<!--注册模块-->default.asp 复制代码 代码如下:<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd"> <html xmlns="http://www.w3.org/>>>详细阅读


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

地址:http://www.17bianji.com/kaifa2/ASP/32176.html

关键词: 探索发现

乐购科技部分新闻及文章转载自互联网,供读者交流和学习,若有涉及作者版权等问题请及时与我们联系,以便更正、删除或按规定办理。感谢所有提供资讯的网站,欢迎各类媒体与乐购科技进行文章共享合作。

网友点评
自媒体专栏

评论

热度

精彩导读
栏目ID=71的表不存在(操作类型=0)