採集中或在線上新增文章中都可以用到此功能採集中或在線上新增文章中都可以用到此功能
俺自己在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=$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= 或 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
%>
以下是例子
程式碼
複製代碼代碼如下:
<form id=form1 name=form1 method=post action=?action=test>
<textarea name=body cols=50 rows=5 id=body>
<img height=180 src=http://cimg2.163.com/cnews/2006/8/21/200608210738371d0a8.jpg width=240 border=0 />
<img class=leftsrc=http://news.163.com/img/netease_logo.gif width=114 />
<img height=60 src=http://cimg2.163.com/cnews/2006/8/18/2006081811465369976.jpg width=120 border=0 />
<img height=60 /></textarea>
<input type=submit name=Submit value=提交/>
</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,False,True,True,FilesPath,NewsUrl)
'對新聞中的第一張圖片創建縮圖
if GetImg(Content,FilesPath)<> then
Imgsrc=GetImg(Content,FilesPath)
Imgsrc=replace(Imgsrc,FilesPath,)
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
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
%>