ASP保存遠程圖片到本地,同時取得第一張圖片並創建縮略圖與加水印
這個還是不錯的，經過測試比較有用，縮略圖/加水印采用的是AspJpeg組件，附件是範例與組件下載。
==========================================================
程序代碼,把代碼保存為"save_img.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
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
%>
以下是 例子代碼：
程序代碼
首先把save_img.asp包含進來
<%@LANGUAGE="VBSCRIPT" CODEPAGE="936"%>
<!--#include file="save_img.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/1999/xhtml">
<head>
<meta http-equiv="Content-Type" content="text/html; charset=gb2312" />
<title>範例</title>
</head>
<body>
<form id="form1" name="form1" method="post" action="test.asp">
<textarea name="body" cols="50" rows="5" id="body">
<img src=http://flydesk.cn/upfiles/20070410142451489.jpg><br /><img src=http://flydesk.cn/upfiles/20070410142532674.jpg>
</textarea>
<input type="submit" name="Submit" value="提交" />
<input name="action" type="hidden" value="test" />
</form>
<%
if request.form("action")="test" then
'圖片開始的字符串
FilesStartStr="src="
'圖片結束的字符串
FilesOverStr="gif|jpg|bmp"
'保存圖片的文件夾
FilesPath="images/"
'取得保存圖片的網站URL 自動判斷是絕對 還是相對路徑 該例子中圖片是絕對地址 所以NEWURL等於沒用如果是../images/123.gif這樣的 就需要指定NEWURL了
NewsUrl=http://flydesk.cn
'取得文章內容
Content =Request.Form("body")
'開始保存圖片
Content=ReplaceSaveRemoteFile(Content,FilesStartStr,FilesOverStr,False,True,True,FilesPath,NewsUrl)
'--------------------------------------------------------------------------------
Dim Jpeg
Set Jpeg = Server.CreateObject("Persits.Jpeg")
If -2147221005=Err then
Response.write "沒有AspJpeg這個組件，請安裝!" '檢查是否安裝AspJpeg組件
Response.End()
End If
'-------------------------對新聞中的第一張圖片創建縮略圖----------------------
if GetImg(Content,FilesPath)<>"" then
Imgsrc=GetImg(Content,FilesPath)
Imgsrc=replace(Imgsrc,FilesPath,"")
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
'------------加水印---------------------------------------------------
saveimg=FilesPath&GetImg(Content,FilesPath) '獲取要加水印圖片的路徑，本例子是獲取第一個圖片加水印
Jpeg.Open Server.MapPath(saveimg) '打開保存圖片的路徑
' 添加文字水印
Jpeg.Canvas.Font.Color = &HFF0000' 紅色
Jpeg.Canvas.Font.Family = "宋體"
Jpeg.Canvas.Font.Bold = True
Jpeg.Canvas.Print Jpeg.OriginalWidth-200,Jpeg.OriginalHeight-50, "CoreData.Cn" '水印離左邊的距離,離頂端的距離,這個是放在右下腳了
'保存文件
Jpeg.Save Server.MapPath(saveimg) '保存添加水印後的圖片
' 注銷對象
Set Jpeg = Nothing
'------------------------------------------------------------------------
'顯示結果
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
%>
</body>
</html>
