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

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

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

Else

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

DefiniteUrl=ConsultUrl & PrimitiveUrl

Else

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

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

Else

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

DefiniteUrl=ConsultUrl & PrimitiveUrl & "/"

Else

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

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

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

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

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

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

if retstr<>"" then

Imglist=split(retstr,"|")

Imgone=replace(Imglist(1),strpath,"")

GetImg=Imgone

else

GetImg=""

end if

end function

以下是例子

程序代码

</textarea>

</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,True,FilesPath,NewsUrl)

'对新闻中的第一张图片创建缩略图

if GetImg(Content,FilesPath)<>"" then

Imgsrc=GetImg(Content,FilesPath)

Imgsrc=replace(Imgsrc,"")

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

'显示结果

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

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

相关推荐

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