'================================================== '函数名：ReplaceSaveRemoteFile '作 用：替换、保存远程图片 '参 数：ConStr ------ 要替换的字符串 '参 数：SaveTf ------ 是否保存文件，False不保存，True保存 '参 数: TistUrl------ 当前网页地址 '================================================== Function ReplaceSaveRemoteFile(ConStr,strInstallDir,strChannelDir,SaveTf,TistUrl) If ConStr="$False$" or ConStr="" or strChannelDir="" Then ReplaceSaveRemoteFile=ConStr Exit Function End If Dim TempStr,TempStr2,TempStr3,Re,Matches,Match,Tempi,TempArray,TempArray2
Set Re = New Regexp Re.IgnoreCase = True Re.Global = True Re.Pattern ="img.+?[^\&;]>" Set Matches =Re.Execute(ConStr) For Each Match in Matches If TempStr>"" then TempStr=TempStr "$Array$" Match.Value Else TempStr=Match.Value End if Next If TempStr>"" Then TempArray=Split(TempStr,"$Array$") TempStr="" For Tempi=0 To Ubound(TempArray) Re.Pattern ="src\s*=\s*.+?\.(gif|jpg|bmp|jpeg|psd|png|svg|dxf|wmf|tiff)" Set Matches =Re.Execute(TempArray(Tempi)) For Each Match in Matches If TempStr>"" then TempStr=TempStr "$Array$" Match.Value Else TempStr=Match.Value End if Next Next End if If TempStr>"" Then IncludePic=1'图片新闻 Re.Pattern ="src\s*=\s*" TempStr=Re.Replace(TempStr,"") End If Set Matches=nothing Set Re=nothing If TempStr="" or IsNull(TempStr)=True Then ReplaceSaveRemoteFile=ConStr Exit function End if TempStr=Replace(TempStr,"""","") TempStr=Replace(TempStr,"'","") TempStr=Replace(TempStr," ","")
Dim RemoteFileurl,SavePath,PathTemp,DtNow,strFileName,strFileType,ArrSaveFileName,RanNum,Arr_Path DtNow=Now() If SaveTf=True then '*********************************** SavePath= strChannelDir year(DtNow) right("0" month(DtNow),2) "/" response.write "链接路径：" savepath "br>" Arr_Path=Split(SavePath,"/") PathTemp="" For Tempi=0 To Ubound(Arr_Path) If Tempi=0 Then PathTemp=Arr_Path(0) "/" ElseIf Tempi=Ubound(Arr_Path) Then Exit For Else PathTemp=PathTemp Arr_Path(Tempi) "/" End If If CheckDir(PathTemp)=False Then If MakeNewsDir(PathTemp)=False Then SaveTf=False Exit For End If End If Next End If
'去掉重复图片开始 TempArray=Split(TempStr,"$Array$") TempStr="" For Tempi=0 To Ubound(TempArray) If Instr(Lcase(TempStr),Lcase(TempArray(Tempi)))1 Then TempStr=TempStr "$Array$" TempArray(Tempi) End If Next TempStr=Right(TempStr,Len(TempStr)-7) TempArray=Split(TempStr,"$Array$") '去掉重复图片结束
'转换相对图片地址开始 TempStr="" For Tempi=0 To Ubound(TempArray) TempStr=TempStr "$Array$" DefiniteUrl(TempArray(Tempi),TistUrl) Next TempStr=Right(TempStr,Len(TempStr)-7) TempStr=Replace(TempStr,Chr(0),"") TempArray2=Split(TempStr,"$Array$") TempStr="" '转换相对图片地址结束 '图片替换/保存 Set Re = New Regexp Re.IgnoreCase = True Re.Global = True For Tempi=0 To Ubound(TempArray2) RemoteFileUrl=TempArray2(Tempi) If RemoteFileUrl>"$False$" And SaveTf=True Then'保存图片 ArrSaveFileName = Split(RemoteFileurl,".") strFileType=Lcase(ArrSaveFileName(Ubound(ArrSaveFileName)))'文件类型 If strFileType="asp" or strFileType="asa" or strFileType="aspx" or strFileType="cer" or strFileType="cdx" or strFileType="exe" or strFileType="rar" or strFileType="zip" then UploadFiles="" ReplaceSaveRemoteFile=ConStr Exit Function End If
If SaveRemoteFile(SavePath strFileName,RemoteFileUrl)=True Then '******************************** PathTemp=SavePath strFileName ConStr=Re.Replace(ConStr,PathTemp) Re.Pattern=strInstallDir strChannelDir UploadFiles=UploadFiles "|" Re.Replace(SavePath strFileName,"") Response.Flush() response.write " nbsp;nbsp;nbsp;图片保存地址：" PathTemp "br>" if Thumb_WaterMark=1 then call SKThumb.AddWaterMark(PathTemp)'水印 Else PathTemp=RemoteFileUrl ConStr=Re.Replace(ConStr,PathTemp) 'UploadFiles=UploadFiles "|" RemoteFileUrl End If ElseIf RemoteFileurl>"$False$" and SaveTf=False Then'不保存图片 Re.Pattern =TempArray(Tempi) ConStr=Re.Replace(ConStr,RemoteFileUrl) UploadFiles=UploadFiles "|" RemoteFileUrl End If Next Set Re=nothing If UploadFiles>"" Then UploadFiles=Right(UploadFiles,Len(UploadFiles)-1) End If ReplaceSaveRemoteFile=ConStr End function
