cl_clscollect.asp

正版创力4.1SQL商业版!!!ASP版。

		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= ChannelDir & 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 Cl.CheckFolder(PathTemp,True)=False Then
				SaveTf=False
				Exit For
			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 Instr("|"& CGet.GetItemConfig("FileExtName",ModuleID) &"|","|"&strFileType&"|")<1 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 & ChannelDir 
				UploadFiles=UploadFiles & "@@@" & Re.Replace(SavePath &strFileName,"")
				Response.Flush()
				response.write " &nbsp;&nbsp;&nbsp;图片保存地址：" & PathTemp & "<br>"
				if Thumb_WaterMark=1 then call CGetThumb.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)-3)
	End If
	ReplaceSaveRemoteFile=ConStr
	End function
	'===============================================
	'函数名：ReSaveRemoteFile
	'作  用：查找文件保存替换
	'参  数：Str   ----原字符串
	'参  数：url   ----当然网站URL
	'参  数：Dir -----保存目录
	'参  数：InSave ------是否保存,True,False
	'返回值：格式化取后的字符串
	'===============================================
	Public Function ReSaveRemoteFile(ByVal str,ByVal URL,ByVal Dir,InSave,ModuleID)
		Dim s_Content,PictureExist
		Dim re
		Dim ContentFile, ContentFileUrl
		Dim strTempUrl,strFileUrl,DirTemp,PathTemp,FileTemp,Tempi,TempUrlArray,Arr_Path
		Dim strFileType,ArrSaveFileName,ranNum
		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)'得到文件地址
			'Dir=Dir & year(Now()) &"-"& right("0" & month(Now()),2) & "/"
			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 Cl.CheckFolder(PathTemp,True)=False Then
						SaveTf=False
						Exit For
					End If
				Next
				'------------------------------------------------------
				TempUrlArray=Split(strTempUrl,"/")
				'----------检查文件是否存在.如果存在换文件名------------------
				Do while True 
					'================
					ArrSaveFileName = Split(strTempUrl,".")
					strFileType=Lcase(ArrSaveFileName(Ubound(ArrSaveFileName)))'文件类型
					Randomize
					RanNum=Int(900*Rnd)+100
					FileTemp = Dir&year(Now()) & right("0" & month(Now()),2) & right("0" & day(Now()),2) & right("0" & hour(Now()),2) & right("0" & minute(Now()),2) & right("0" & second(Now()),2) & ranNum & "." & strFileType'生成文件名
					'================
					If CheckFile(FileTemp)=False then
						Exit Do
					end if
				loop 
				'-------------------------------------------------------------------
				If Instr("|"& CGet.GetItemConfig("FileExtName",ModuleID) &"|","|"&strFileType&"|")<1 Then
					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
				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
	'==================================================
	'函数名: CheckFile
	'作  用：检查某一文件是否存在
	'参  数：FileName ------ 文件地址 如:/swf/1.swf
	'返回值：False  ----  True
	'==================================================
	Public Function CheckFile(FileName)
		On Error Resume Next
		Dim FsoObj
		Set FsoObj = Server.CreateObject(Trim(Cl.Web_Info(13)))
		If Not FsoObj.FileExists(Server.MapPath(FileName)) Then
			CheckFile = False
			Exit Function
		End If
		CheckFile = True:Set FsoObj = Nothing
	End Function
	'===============================================
	'过程名：SaveRemoteFile
	'作  用：保存远程的文件到本地
	'参  数：LocalFileName ------ 本地文件名
	'参  数：RemoteFileUrl ------ 远程文件URL
	'===============================================
	Function SaveRemoteFile(LocalFileName,RemoteFileUrl)
		SaveRemoteFile=True
		dim Ads,Retrieval,GetRemoteData	
		On Error Resume Next
		Set Retrieval = Server.CreateObject("Microsoft.XMLHTTP")
		With Retrieval
			.Open "Get", RemoteFileUrl, False, "", ""
			.Send
			If .Readystate<>4 or .Status > 300 then
				SaveRemoteFile=False
				Exit Function
			End If
			GetRemoteData = .ResponseBody
		End With
		Set Retrieval = Nothing

		If MaxFileSize > 0 Then
			If LenB(GetRemoteData) > MaxFileSize Then Exit Function
		End If
		Response.Write "大小："&Round(LenB(GetRemoteData)/1024) & "KB"
		Set Ads = Server.CreateObject("Adodb.Stream")
		With Ads
			.Type = 1
			.Open
			.Write GetRemoteData
			.SaveToFile server.MapPath(LocalFileName),2
			.Cancel()
			.Close()
		End With
		If Err.number<>0 then
			SaveRemoteFile=False
			Exit Function
			Err.Clear
		End If
		Set Ads=nothing
	end Function
	'===============================================
	'函数名：GetSaveDir()
	'sType=类型
	'作  用：读取文件保存目录设置
	'===============================================
	Function GetSaveDir(sType,SaveFileUrl)
		Dim strInstallDir,CacheTemp,rs,strtemp,ChannelDir,Arr_Path,Tempi,PathTemp,SaveTf,TempUrlArray,Ranfilestr
		strInstallDir=trim(request.ServerVariables("SCRIPT_NAME"))
		strInstallDir=left(strInstallDir,instrrev(lcase(strInstallDir),"/")-1)
		set rs = Conn_C.execute("Select top 1 Dir,MaxFileSize,FileExtName,Timeout from ModuleInfo where ID=" & sType)
		strtemp = strtemp  & rs("Dir")
		strtemp = strtemp & SaveFileUrl & year(Now()) &"-"& right("0" & month(Now()),2) & "/"
		strtemp =replace(strtemp,"{$DefaultDir}",Cl.WebDir&Cl.Upload_Setting(0)&Cl.ChannelUpLoadSetting(1))
		GetSaveDir=Cl.ReplaceDir(strtemp)
		rs.close
		set rs=nothing
	end function
	'===============================================
	'函数名：SaveFile()
	'参  数: sType=模块
	'参  数: FileUrl=远程文件地址
	'作  用：按频道功能保存远程文件替换地址
	'===============================================
	Function SaveFile(sType,FileUrl,SaveFileUrl)
		Dim strInstallDir,CacheTemp,rs,strtemp,ChannelDir,Arr_Path,Tempi,PathTemp,SaveTf,TempUrlArray,Ranfilestr,Ranfilestr1
		Dim SqlTemp
		Dim strFileType,ArrSaveFileName,ranNum
		FileUrl=replace(replace(FileUrl,"""","")," ","")
		strtemp=GetSaveDir(sType,SaveFileUrl)
		'response.write "保存路径："&SavefilePath
		Arr_Path=Split(strtemp,"/")
		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 Cl.CheckFolder(PathTemp,True)=False Then
				SaveTf=False
				Exit For
			End If
		Next
		TempUrlArray=Split(FileUrl,"/")
		'================
		ArrSaveFileName = Split(FileUrl,".")
		strFileType=Lcase(ArrSaveFileName(Ubound(ArrSaveFileName)))'文件类型
		If Instr("|"& CGet.GetItemConfig("FileExtName",sType) &"|","|"&strFileType&"|")<1 Then
			SaveFile=False
			Exit Function
		End If
		Randomize
		RanNum=Int(900*Rnd)+100
		Ranfilestr = strtemp&year(Now()) & right("0" & month(Now()),2) & right("0" & day(Now()),2) & right("0" & hour(Now()),2) & right("0" & minute(Now()),2) & right("0" & second(Now()),2) & ranNum & "." & strFileType'生成文件名
		'================
		'Call SaveRemoteFile(Ranfilestr,FileUrl)'保存远程文件
		If SaveRemoteFile(Ranfilestr,FileUrl)<>False then'保存远程文件
			Ranfilestr1=Ranfilestr
			if Thumb_WaterMark=1 And sType=3 then call CGetThumb.AddWaterMark(Ranfilestr)'水印
			SaveFile = Ranfilestr1
		Else
			SaveFile = False
		End if
	End function
	
	Private Function CorrectPattern(ByVal str)
		str = Replace(str, "\", "\\")
		str = Replace(str, "~", "\~")
		str = Replace(str, "!", "\!")
		str = Replace(str, "@", "\@")
		str = Replace(str, "#", "\#")
		str = Replace(str, "%", "\%")
		str = Replace(str, "^", "\^")
		str = Replace(str, "&", "\&")
		str = Replace(str, "*", "\*")
		str = Replace(str, "(", "\(")
		str = Replace(str, ")", "\)")
		str = Replace(str, "-", "\-")
		str = Replace(str, "+", "\+")
		str = Replace(str, "[", "\[")
		str = Replace(str, "]", "\]")
		str = Replace(str, "<", "\<")
		str = Replace(str, ">", "\>")
		str = Replace(str, ".", "\.")
		str = Replace(str, "/", "\/")
		str = Replace(str, "?", "\?")
		str = Replace(str, "=", "\=")
		str = Replace(str, "|", "\|")
		str = Replace(str, "$", "\$")
		CorrectPattern = str
	End Function
	'===============================================
	'函数名：FormatRemoteUrl