ASP分析内容自动保存远程图片到本地并取得第一

当前位置：网学 > 编程文档 > ASP > 正文

来源：Http://myeducs.cn 联系QQ：

作者：用户投稿来源：网络发布时间： 12/11/25

1 2 下一页

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

　　俺自己在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="$Falsecontentquot; Then DefiniteUrl="$Falsecontentquot; 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="$Falsecontentquot; 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="$Falsecontentquot; or ConStr="" Then ReplaceSaveRemoteFile="$Falsecontentquot; 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 & "$Arraycontentquot; & 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,"$Arraycontentquot;) For Tempi=0 To Ubound(TempArray) RemoteFileurl=DefiniteUrl(TempArray(Tempi),TistUrl) If RemoteFileurl<>"$Falsecontentquot; 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<>"$Falsecontentquot; and SaveTf=False Then'不保存图片 SaveFileName=RemoteFileUrl ConStr=Replace(ConStr,TempArray(Tempi),SaveFileName) End If If RemoteFileUrl<>"$Falsecontentquot; 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 %>