拍拍尘土

<%
'==================================================
'函数名：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" alt="中国维和人数大国之首" src="http://cimg2.163.com/cnews/2006/8/18/200608181506554fd8f.jpg" width="120" border="0" />
     </textarea>
     <input type="submit" name="Submit" value="提交" />
</form>
<%
if request.QueryString("action")="test" then
         '图片开始的字符串
         FilesStartStr="src="
         '图片结束的字符串
         FilesOverStr="gif|jpg|bmp"
         '保存图片的文件夹
         FilesPath="qq"
         '取得保存图片的网站URL 自动判断是绝对 还是相对路径
         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
%>