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

这是本人在SNA新闻采集系统 For 动力3.62 里使用的几个函数

可以普遍的使用在采集 或者 在线添加文章中

以下是函数程序代码

<%

'==================================================

'函数名：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)="org" Then

DefiniteUrl="http://" & PrimitiveUrl & "/"

Else

DefiniteUrl=Left(ConsultUrl,"/")) & "/" & PrimitiveUrl

End If

End If

Else

If Right(ConsultUrl,1)="/" Then

DefiniteUrl=ConsultUrl & PrimitiveUrl & "/"

Else

DefiniteUrl=Left(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,"")

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,"")

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,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

'==================================================

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

%>