ReplaceSaveRemoteFile 替换、保存远程图片 的代码

1. '==================================================  
2. '函数名：ReplaceSaveRemoteFile  
3. '作  用：替换、保存远程图片  
4. '参  数：ConStr ------ 要替换的字符串  
5. '参  数：SaveTf ------ 是否保存文件，False不保存，True保存  
6. '参  数: TistUrl------ 当前网页地址  
7. '==================================================  
8. Function ReplaceSaveRemoteFile(ConStr,strInstallDir,strChannelDir,SaveTf,TistUrl)  
9.    If ConStr="$False$" or ConStr="" or strChannelDir="" Then  
10.       ReplaceSaveRemoteFile=ConStr  
11.       Exit Function  
12.    End If  
13.    Dim TempStr,TempStr2,TempStr3,Re,Matches,Match,Tempi,TempArray,TempArray2  
14.  
15.    Set Re = New Regexp   
16.    Re.IgnoreCase = True   
17.    Re.Global = True  
18.    Re.Pattern ="<img.+?[^\>]>"  
19.    Set Matches =Re.Execute(ConStr)   
20.    For Each Match in Matches  
21.       If TempStr<>"" then   
22.          TempStr=TempStr & "$Array$" & Match.Value  
23.       Else  
24.          TempStr=Match.Value  
25.       End if  
26.    Next  
27.    If TempStr<>"" Then  
28.       TempArray=Split(TempStr,"$Array$")  
29.       TempStr=""  
30.       For Tempi=0 To Ubound(TempArray)  
31.          Re.Pattern ="src\s*=\s*.+?\.(gif|jpg|bmp|jpeg|psd|png|svg|dxf|wmf|tiff)"  
32.          Set Matches =Re.Execute(TempArray(Tempi))   
33.          For Each Match in Matches  
34.             If TempStr<>"" then   
35.                TempStr=TempStr & "$Array$" & Match.Value  
36.             Else  
37.                TempStr=Match.Value  
38.             End if  
39.          Next  
40.       Next  
41.    End if  
42.    If TempStr<>"" Then  
43.          IncludePic=1'图片新闻  
44.       Re.Pattern ="src\s*=\s*"  
45.       TempStr=Re.Replace(TempStr,"")  
46.    End If  
47.    Set Matches=nothing  
48.    Set Re=nothing  
49.    If TempStr="" or IsNull(TempStr)=True Then  
50.       ReplaceSaveRemoteFile=ConStr  
51.       Exit function  
52.    End if  
53.    TempStr=Replace(TempStr,"""","")  
54.    TempStr=Replace(TempStr,"'","")  
55.    TempStr=Replace(TempStr," ","")  
56.  
57.    Dim RemoteFileurl,SavePath,PathTemp,DtNow,strFileName,strFileType,ArrSaveFileName,RanNum,Arr_Path  
58.    DtNow=Now()  
59.    If SaveTf=True then  
60.  '***********************************  
61.       SavePath= strChannelDir & year(DtNow) & right("0" & month(DtNow),2) & "/"  
62.       response.write "链接路径：" & savepath & "<br>"  
63.       Arr_Path=Split(SavePath,"/")  
64.       PathTemp=""  
65.       For Tempi=0 To Ubound(Arr_Path)  
66.          If Tempi=0 Then  
67.             PathTemp=Arr_Path(0) & "/"  
68.          ElseIf Tempi=Ubound(Arr_Path) Then  
69.             Exit For  
70.          Else  
71.             PathTemp=PathTemp & Arr_Path(Tempi) & "/"  
72.          End If  
73.          If CheckDir(PathTemp)=False Then  
74.             If MakeNewsDir(PathTemp)=False Then  
75.                SaveTf=False  
76.                Exit For  
77.             End If  
78.          End If  
79.       Next  
80.    End If  
81.  
82.    '去掉重复图片开始  
83.    TempArray=Split(TempStr,"$Array$")  
84.    TempStr=""  
85.    For Tempi=0 To Ubound(TempArray)  
86.       If Instr(Lcase(TempStr),Lcase(TempArray(Tempi)))<1 Then  
87.          TempStr=TempStr & "$Array$" & TempArray(Tempi)  
88.       End If  
89.    Next  
90.    TempStr=Right(TempStr,Len(TempStr)-7)  
91.    TempArray=Split(TempStr,"$Array$")  
92.    '去掉重复图片结束  
93.  
94.    '转换相对图片地址开始  
95.    TempStr=""  
96.    For Tempi=0 To Ubound(TempArray)  
97.       TempStr=TempStr & "$Array$" & DefiniteUrl(TempArray(Tempi),TistUrl)  
98.    Next  
99.    TempStr=Right(TempStr,Len(TempStr)-7)  
100.    TempStr=Replace(TempStr,Chr(0),"")  
101.    TempArray2=Split(TempStr,"$Array$")  
102.    TempStr=""  
103.    '转换相对图片地址结束  
104.     '图片替换/保存  
105.    Set Re = New Regexp  
106.    Re.IgnoreCase = True   
107.    Re.Global = True  
108.    For Tempi=0 To Ubound(TempArray2)  
109.       RemoteFileUrl=TempArray2(Tempi)  
110.       If RemoteFileUrl<>"$False$" And SaveTf=True Then'保存图片  
111.          ArrSaveFileName = Split(RemoteFileurl,".")  
112.      strFileType=Lcase(ArrSaveFileName(Ubound(ArrSaveFileName)))'文件类型  
113.          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  
114.             UploadFiles=""  
115.             ReplaceSaveRemoteFile=ConStr  
116.             Exit Function  
117.          End If  
118.  
119.          Randomize  
120.          RanNum=Int(900*Rnd)+100  
121.      strFileName = year(DtNow) & right("0" & month(DtNow),2) & right("0" & day(DtNow),2) & right("0" & hour(DtNow),2) & right("0" & minute(DtNow),2) & right("0" & second(DtNow),2) & ranNum & "." & strFileType  
122.          Re.Pattern =TempArray(Tempi)  
123.  
124.      If SaveRemoteFile(SavePath & strFileName,RemoteFileUrl)=True Then  
125. '********************************  
126.             PathTemp=SavePath & strFileName   
127.             ConStr=Re.Replace(ConStr,PathTemp)  
128.             Re.Pattern=strInstallDir & strChannelDir   
129.             UploadFiles=UploadFiles & "|" & Re.Replace(SavePath &strFileName,"")  
130.             Response.Flush()  
131.             response.write "    图片保存地址：" & PathTemp & "<br>"  
132.             if Thumb_WaterMark=1 then call SKThumb.AddWaterMark(PathTemp)'水印  
133.          Else  
134.             PathTemp=RemoteFileUrl  
135.             ConStr=Re.Replace(ConStr,PathTemp)  
136.             'UploadFiles=UploadFiles & "|" & RemoteFileUrl  
137.          End If  
138.       ElseIf RemoteFileurl<>"$False$" and SaveTf=False Then'不保存图片  
139.          Re.Pattern =TempArray(Tempi)  
140.          ConStr=Re.Replace(ConStr,RemoteFileUrl)  
141.          UploadFiles=UploadFiles & "|" & RemoteFileUrl  
142.       End If  
143.    Next     
144.    Set Re=nothing  
145.    If UploadFiles<>"" Then  
146.       UploadFiles=Right(UploadFiles,Len(UploadFiles)-1)  
147.    End If  
148.    ReplaceSaveRemoteFile=ConStr  
149. End function