<% '================================================== '函數(shù)名：CheckDir2 '作 用：檢查文件夾是否存在 '參 數(shù)：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 '================================================== '函數(shù)名：MakeNewsDir2 '作 用：創(chuàng)建新的文件夾 '參 數(shù)：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 '================================================== '函數(shù)名：DefiniteUrl '作 用：將相對(duì)地址轉(zhuǎn)換為絕對(duì)地址 '參 數(shù)：PrimitiveUrl ------要轉(zhuǎn)換的相對(duì)地址 '參 數(shù)：ConsultUrl ------當(dāng)前網(wǎng)頁(yè)地址 '================================================== 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,"http://","/") DefiniteUrl=Replace(DefiniteUrl,"://","://") Else DefiniteUrl="$False$" End If End Function '================================================== '函數(shù)名：ReplaceSaveRemoteFile '作 用：替換、保存遠(yuǎn)程文件 '參 數(shù)：ConStr ------ 要替換的字符串 '參 數(shù)：StarStr ----- 前導(dǎo) '參 數(shù)：OverStr ----- '參 數(shù)：IncluL ------ '參 數(shù)：IncluR ------ '參 數(shù)：SaveTf ------ 是否保存文件，F(xiàn)alse不保存，True保存 '參 數(shù)：SaveFilePath- 保存文件夾 '參 數(shù): TistUrl------ 當(dāng)前網(wǎng)頁(yè)地址 '================================================== 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 & "/" '圖片轉(zhuǎn)換/保存 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 '================================================== '過(guò)程名：SaveRemoteFile '作 用：保存遠(yuǎn)程的文件到本地 '參 數(shù)：LocalFileName ------ 本地文件名 '參 數(shù)：RemoteFileUrl ------ 遠(yuǎn)程文件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 '================================================== '過(guò)程名：GetImg '作 用：取得文章中第一張圖片 '參 數(shù)：str ------ 文章內(nèi)容 '參 數(shù)：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 %>
