<% 
'================================================== 
'函數名：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 
%>

<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="left"src="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 
%>