sk_funcls.asp

清风信息自动采集生成系统 很好用的大家试试看

	'===============================================
	'函数名：GetArray
	'作  用：提取链接地址，以$Array$分隔
	'参  数：ConStr ------提取地址的原字符
	'参  数：StartStr ------开始字符串
	'参  数：OverStr ------结束字符串
	'参  数：IncluL ------是否包含StartStr
	'参  数：IncluR ------是否包含OverStr
	'===============================================
	Function GetArray(Byval ConStr,StartStr,OverStr,IncluL,IncluR)
	   Dim TempStr,TempStr2,objRegExp,Matches,Match,Templisturl,TempStr_i
	   Dim s,o 
	   On Error Resume Next
	   If ConStr="$False$" or ConStr="" Or IsNull(ConStr)=True or StartStr="" Or OverStr="" or  IsNull(StartStr)=True Or IsNull(OverStr)=True Then
		  GetArray="$False$"
		  Exit Function
	   End If
	   StartStr=ReplaceTrim(StartStr) : OverStr=ReplaceTrim(OverStr) : ConStr=ConStr
	   s=Len(StartStr) : o=Len(OverStr)
	   TempStr=""
	   Set objRegExp = New Regexp 
	   objRegExp.IgnoreCase = True 
	   objRegExp.Global = True
	   objRegExp.Pattern = "("&CorrectPattern(StartStr)&").+?("&CorrectPattern(OverStr)&")"
	   Set Matches =objRegExp.Execute(ConStr) 
	   For Each Match in Matches
		  'If Templisturl =Match.Value then
		  'Else
		  		TempStr_i=Match.Value
		  	  	If IncluL=False then
					TempStr_i=Right(TempStr_i,Len(TempStr_i) -S)
				End if
				If IncluR=False then
					TempStr_i=Left(TempStr_i,Len(TempStr_i) - O)
				End if	
			  	TempStr=TempStr & "$Array$" & TempStr_i
		  '	  	Templisturl = Match.Value
		  'End if
	   Next 
	   Set Matches=nothing
	
	   If TempStr="" Then
		  GetArray="$False$"
		  Exit Function
	   End If
	   TempStr=Right(TempStr,Len(TempStr)-7)
	   Set objRegExp=nothing
	   Set Matches=nothing

	   If TempStr="" then
		  GetArray="$False$"
	   Else
		  GetArray=TempStr
	   End if
	End Function
	'===============================================
	'函数名：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
	
			 Randomize
			 RanNum=Int(900*Rnd)+100
		 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
			 Re.Pattern =TempArray(Tempi)
			 
		 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
	'===============================================
	'函数名：ReSaveRemoteFile
	'作  用：查找文件保存替换
	'参  数：Str   ----原字符串
	'参  数：url   ----当然网站URL
	'参  数：Dir -----保存目录
	'参  数：InSave ------是否保存,True,False
	'返回值：格式化取后的字符串
	'===============================================
	Public Function ReSaveRemoteFile(ByVal str, ByVal URL, ByVal Dir,InSave)
		Dim s_Content
		Dim re
		Dim ContentFile, ContentFileUrl
		Dim strTempUrl,strFileUrl,DirTemp,PathTemp,FileTemp,Tempi,TempUrlArray,Arr_Path
		s_Content = str
		On Error Resume Next
		Set re = New RegExp
		re.IgnoreCase = True
		re.Global = True
		re.Pattern = "((src=|href=)((\S)+[.]{1}(" & AllExtName & ")))"
		Set ContentFile = re.Execute(s_Content)
		Dim sContentUrl(), n, i, bRepeat
		n = 0
		For Each ContentFileUrl In ContentFile
			strFileUrl = Replace(Replace(Replace(Replace(ContentFileUrl.Value, "src=", "", 1, -1, 1), "href=", "", 1, -1, 1), "'", ""), Chr(34), "")
			If n = 0 Then
				n = n + 1
				ReDim sContentUrl(n)
				sContentUrl(n) = strFileUrl
			Else
				bRepeat = False
				For i = 1 To UBound(sContentUrl)
					If UCase(strFileUrl) = UCase(sContentUrl(i)) Then
						bRepeat = True
						Exit For
					End If
				Next
				If bRepeat = False Then
					n = n + 1
					ReDim Preserve sContentUrl(n)
					sContentUrl(n) = strFileUrl
				End If
			End If
		Next
		If n = 0 Then
			ReSaveRemoteFile = s_Content
			Exit Function
		End If
		For i = 1 To n 
			strTempUrl = sContentUrl(i) : strTempUrl = FormatRemoteUrl(strTempUrl,URL)'得到文件地址
			IF InSave=True then
				Arr_Path=Split(Dir,"/")
				'----------建目录-----------------------
				  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
				 '------------------------------------------------------
				TempUrlArray=Split(strTempUrl,"/")
				'----------检查文件是否存在.如果存在换文件名------------------
				Do while True 
					FileTemp=Dir &  MakeRandom(5) & TempUrlArray(Ubound(TempUrlArray))'生成随机文件名
					If CheckFile(FileTemp)=False then
						Exit Do
					end if
				loop 
				'-------------------------------------------------------------------

				If SaveRemoteFile(FileTemp,strTempUrl)=True then
					Response.Write FileTemp & "保存成功" & "<Br>"
					s_Content = Replace(s_Content,sContentUrl(i),FileTemp, 1, -1, 1)'替换地址	
				Else
					Response.Write FileTemp & "保存失败" & "<Br>"
				End if
			Else
				s_Content = Replace(s_Content,sContentUrl(i),strTempUrl, 1, -1, 1)'替换地址		
			End If	
		Next
		Set re = Nothing
		PictureExist = True
		ReSaveRemoteFile = s_Content
		Exit Function
	End Function
	'===============================================
	'过程名：SaveRemoteFile
	'作  用：保存远程的文件到本地
	'参  数：LocalFileName ------ 本地文件名
	'参  数：RemoteFileUrl ------ 远程文件URL
	'===============================================
	Function SaveRemoteFile(LocalFileName,RemoteFileUrl)