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

俺从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
%>

时间： 2024-10-22 18:58:42

ASP分析内容自动保存远程图片到本地并取得第一张图片创建缩略图的相关文章

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

采集中 或者 在线添加文章中 都可以用到此功能 俺自己在baidu上搜索的保存远程图片到本地的代码 感觉比较难用点 而且没有现成的比较全的代码 俺也看不懂 俺从 SNA新闻采集系统 For 3.62 (程序制作:ansir)里提取了点函数 用下 比较简单好用 以下是函数 程序代码  复制代码 代码如下: <% '================================================== '函数名:CheckDir2 '作 用:检查文件夹是否存在 '参 数:FolderP

ASP保存远程图片到本地 同时取得第一张图片

这是本人在SNA新闻采集系统 For 动力3.62 里使用的几个函数可以普遍的使用在采集 或者 在线添加文章中以下是函数程序代码<%'=================================================='函数名:DefiniteUrl'作 用:将相对地址转换为绝对地址'参 数:PrimitiveUrl ------要转换的相对地址'参 数:ConsultUrl ------当前网页地址'=======================================

ASP保存远程图片到本地，并生成缩略图

ASP通过XMLHTTP获取远程图片流数据,并保存到本地,把第一张采集到的图片生成缩略图. 具体代码如下: <% '================================================== '函数名:CheckDir2 '作 用:检查文件夹是否存在 '参 数:FolderPath ------文件夹地址 '================================================== Function CheckDir2(byval Folder

保存远程图片到本地服务器几种方法[php,asp]

function get_file($url,$folder){    set_time_limit (24 * 60 * 60);       $destination_folder = $folder?$folder.'/':'';//文件下载保存目录            $newfname = $destination_folder . basename($url);    $file = fopen ($url, "rb");    if ($file) {    $newf

php下保存远程图片到本地的办法_php技巧

今天在整理资料的时候发现以前找到的一个函数,通过这个函数我们就可以实现上面的功能. 主要函数: 复制代码 代码如下: function GrabImage($url,$filename="") { if($url=="") return false; if($filename=="") { $ext=strrchr($url,"."); if($ext!=".gif" && $ext!=&q

ASPX保存远程图片到本地的两种方法的函数

  Function UpRemoteFileToLocal(ByVal UpType As String, ByVal RemoteUrl As String, ByVal LocalFile As String) As Boolean        Dim TmpResult As Boolean = False        Select Case UpType       Case "xmlhttp"           'With MSXML2           Dim m

ASP保存远程图片

记得很多的编辑器.自动采集系统都一个自动保存远程图片的功能,大概原理就是利用xmlhttp对象获取图片,然后用流对象写入保存,参照网上的代码,自己写了一个,与流传的代码没什么区别!代码如下,就一个函数: <% Function SaveRemoteFile(sSavePath,sRemoteFileUrl) On Error Resume Next SaveRemoteFile = False Dim oXML : Set oXML = Server.CreateObject("Micro

asp保存远程图片（破防盗链系统）

简单实例一 这里可用到xmlhttp 和文件对象 fso,  代码如下 复制代码 <% Function SaveRemoteFile(sSavePath,sRemoteFileUrl) On Error Resume Next SaveRemoteFile = False Dim oXML : Set oXML = Server.CreateObject("Microsoft.XMLHTTP") With oXML .Open "Get",sRemoteFi

ASP替换、保存远程图片实现代码_应用技巧

ASP通过函数来实现替换.保存远程图片,完成自动采集图片.提取图片的功能,函数中自动判断重复图片,智能分析链接路径,并转成成相对的图片地址保存在你指定的网站目录中,我们可将此函数用在后台的编辑器中,当你复制了含有图片的内容后,本代码会自动帮你上传图片.同时本代码也是采集程序中的重要处理函数,函数代码如下: Function ReplaceSaveRemoteFile(ConStr,strInstallDir,strChannelDir,SaveTf,TistUrl) If ConStr="$Fa