upload.asp

淘客网上商店网站程序 淘客网上商店网站程序 淘客网上商店网站程序

		sAllowExt	= Trim(sTrSetting(13))
		nAllowSize	= Clng(sTrSetting(14))
		sIsReName	= Cint(sTrSetting(15))			'是否重命名
	Case "MEDIA"
		sAllowExt	= Trim(sTrSetting(10))
		nAllowSize	= Clng(sTrSetting(11))
		sIsReName	= Cint(sTrSetting(12))			'是否重命名
	Case "FLASH"
		sAllowExt	= Trim(sTrSetting(7))
		nAllowSize	= Clng(sTrSetting(8))
		sIsReName	= Cint(sTrSetting(9))			'是否重命名
	Case Else
		sAllowExt	= Trim(sTrSetting(4))
		nAllowSize	= Clng(sTrSetting(5))
		sIsReName	= Cint(sTrSetting(6))			'是否重命名
	End Select
	' 任何情况下都不允许上传asp脚本文件
	sAllowExt		= Replace(UCase(sAllowExt), "ASP", "")
End Sub

'================================================
'作  用：替换字符串中的远程文件为本地文件并保存远程文件
'参  数：
'	sHTML		: 要替换的字符串
'	sExt		: 执行替换的扩展名
'================================================
Function ReplaceRemoteUrl(sHTML, sExt)
	Dim s_Content
	s_Content = sHTML
	If Cl.ChkObjInstalled("Microsoft.XMLHTTP") = False then
		ReplaceRemoteUrl = s_Content
		Exit Function
	End If
	
	Dim re, RemoteFile, RemoteFileurl, SaveFileName, SaveFileType
	Set re = new RegExp
	re.IgnoreCase  = True
	re.Global = True
	re.Pattern = "((http|https|ftp|rtsp|mms):(\/\/|\\\\){1}(([A-Za-z0-9_-])+[.]){1,}(net|com|cn|org|cc|tv|[0-9]{1,3})(\S*\/)((\S)+[.]{1}(" & sExt & ")))"

	Set RemoteFile = re.Execute(s_Content)
	Dim a_RemoteUrl(), n, i, bRepeat
	n = 0
	' 转入无重复数据
	For Each RemoteFileurl in RemoteFile
		If n = 0 Then
			n = n + 1
			Redim a_RemoteUrl(n)
			a_RemoteUrl(n) = RemoteFileurl
		Else
			bRepeat = False
			For i = 1 To UBound(a_RemoteUrl)
				If UCase(RemoteFileurl) = UCase(a_RemoteUrl(i)) Then
					bRepeat = True
					Exit For
				End If
			Next
			If bRepeat = False Then
				n = n + 1
				Redim Preserve a_RemoteUrl(n)
				a_RemoteUrl(n) = RemoteFileurl
			End If
		End If		
	Next
	' 开始替换操作
	nFileNum = 0
	Set Upload = New UpFile_Cls
	InitUpLoad_Cls
	For i = 1 To n
		SaveFileType = Mid(a_RemoteUrl(i), InstrRev(a_RemoteUrl(i), ".") + 1)
		if sIsReName=1 then
			SaveFileName = Upload.NewFileName & "." &SaveFileType
		else
			SaveFileName = Mid(a_RemoteUrl(i), InstrRev(a_RemoteUrl(i), "/") + 1)
		end if
		If SaveRemoteFile(SaveFileName, a_RemoteUrl(i)) = True Then
			nFileNum = nFileNum + 1
			If nFileNum > 0 Then
				sOriginalFileName = sOriginalFileName & "|"
				sSaveFileName = sSaveFileName & "|"
				sPathFileName = sPathFileName & "|"
			End If
			sOriginalFileName = sOriginalFileName & Mid(a_RemoteUrl(i), InstrRev(a_RemoteUrl(i), "/") + 1)
			sSaveFileName = sSaveFileName & SaveFileName
			sPathFileName = sPathFileName & sContentPath & SaveFileName
			s_Content = Replace(s_Content, a_RemoteUrl(i), sContentPath & SaveFileName, 1, -1, 1)
			If Upload.PreviewType<>999 then
				F_FileName = sUploadDir & SaveFileName
				F_Viewname = sPreviewpath & "pre" & Replace(SaveFileName,SaveFileType,"") & "jpg"
				Upload.CreateView F_FileName,F_Viewname,SaveFileType
			End If
		End If
	Next
	Set Upload=Nothing
	ReplaceRemoteUrl = s_Content
End Function

'================================================
'作  用：保存远程的文件到本地
'参  数：s_LocalFileName ------ 本地文件名
'		 s_RemoteFileUrl ------ 远程文件URL
'返回值：True  ----成功
'        False ----失败
'================================================
Function SaveRemoteFile(s_LocalFileName, s_RemoteFileUrl)
	Dim Ads, Retrieval, GetRemoteData
	Dim bError
	bError = False
	SaveRemoteFile = False
	On Error Resume Next
	Set Retrieval = Server.CreateObject("Msxml2.XMLHTTP.3.0")
	If Err Then
		Err.Clear
		Set Retrieval = Server.CreateObject("Msxml2.XMLHTTP")
		If Err Then
			Err.Clear
			Rem 服务器不支持Msxml，本程序无法运行！
			Exit Function
		End If
	End If
	'Set Retrieval = Server.CreateObject("Microsoft.XMLHTTP")
	With Retrieval
		.Open "Get", s_RemoteFileUrl, False', "", ""
		.Send
		GetRemoteData = .ResponseBody
	End With
	Set Retrieval = Nothing

	If LenB(GetRemoteData) > nAllowSize*1024 Then
		bError = True
	Else
		Set Ads = Server.CreateObject("Adodb." & "Str" & "eam")
		With Ads
			.Type = 1
			.Open
			.LoadFromFile(Server.MapPath(sUploadDir & s_LocalFileName))
			if Err.Number=0 then
			s_LocalFileName=Minute(now) & Second(now) & s_LocalFileName
			else
			Err.Clear
			End if
			.Write GetRemoteData
			.SaveToFile Server.MapPath(sUploadDir & s_LocalFileName), 2
			.Cancel()
			.Close()
		End With
		Set Ads=Nothing
	End If

	If Err.Number = 0 And bError = False Then
		SaveRemoteFile = True
		Cl.InToColumn "Cl_UpFileLog","UserID,UserName,UserGroupID,UserIP,UpFileName,SaveFileName,UpFileTime,ChannelID,IsUse","'"&Cl.UserID&"','"&Cl.MemberName&"','"&Cl.UserGroupID&"','"&Cl.UserTrueIP&"','"&s_RemoteFileUrl&"','"&sUploadDir & s_LocalFileName&"','"&Now&"',"&sChannelID&",0"
		Call OutScriptNoBack("parent.AddUploadFiles('"&sTObj&"','" & sUploadDir & s_LocalFileName & "','" & s_LocalFileName & "');")
		if Err.Number<>0 then Err.Clear
	Else
		Err.Clear
	End If
End Function

Sub InitUpLoad_Cls()
	If Cl.Upload_Setting(3)="1" Then
		DrawInfo = Cl.Upload_Setting(4)
	ElseIf Cl.Upload_Setting(3)="2" Then
		DrawInfo = Replace(Cl.Upload_Setting(9),"{$webdir}",Cl.WebDir)
	Else
		DrawInfo = ""
	End If
	If DrawInfo = "" Then Cl.Upload_Setting(3) = 0
	Upload.UploadType			= Cint(Cl.Upload_Setting(1))	'设置上传组件类型
	Upload.UploadPath			= sUploadDir					'设置上传路径
	Upload.InceptFileType		= Replace(sAllowExt,"|",",")	'设置上传文件限制
	Upload.MaxSize				= Int(nAllowSize)				'单位 KB
	Upload.InceptMaxFile		= 10							'每次上传文件个数上限
	'Upload.ChkSessionName		= "UploadCode"&ChannelID&UpFileType'防止重复提交。
	Upload.IsReName             = sIsReName				'是否重命名，by 梅傲风。
	Upload.PreviewType			= Cint(Cl.Upload_Setting(2))	'设置预览图片组件类型
	Upload.PreviewImageWidth	= Cl.Upload_Setting(15)		'设置预览图片宽度
	Upload.PreviewImageHeight	= Cl.Upload_Setting(16)		'设置预览图片高度
	Upload.DrawImageWidth		= Cl.Upload_Setting(12)			'设置水印图片或文字区域宽度
	Upload.DrawImageHeight		= Cl.Upload_Setting(13)			'设置水印图片或文字区域高度
	Upload.DrawGraph			= Cl.Upload_Setting(10)			'设置水印透明度
	Upload.DrawFontColor		= Cl.Upload_Setting(6)			'设置水印文字颜色
	Upload.DrawFontFamily		= Cl.Upload_Setting(7)			'设置水印文字字体格式
	Upload.DrawFontSize			= Cl.Upload_Setting(5)			'设置水印文字字体大小
	Upload.DrawFontBold			= Cl.Upload_Setting(8)			'设置水印文字是否粗体
	Upload.DrawInfo				= DrawInfo				'设置水印文字信息或图片信息
	Upload.DrawType				= Cl.Upload_Setting(3)			'0=不加载水印 ，1=加载水印文字，2=加载水印图片
	Upload.DrawXYType			= Cl.Upload_Setting(14)		'"0" =左上，"1"=左下,"2"=居中,"3"=右上,"4"=右下
	Upload.DrawSizeType			= Cl.Upload_Setting(17)		'"0"=固定缩小，"1"=等比例缩小
	If Cl.Upload_Setting(11)<>"" Then
		Upload.TransitionColor	= Cl.Upload_Setting(11)		'透明度颜色设置
	End If
End Sub

' ============================================
' 去除Html格式，用于从数据库中取出值填入输入框时
' 注意：value="?"这边一定要用双引号
' ============================================
Function inHTML(str)
	Dim sTemp
	sTemp = str
	inHTML = ""
	If IsNull(sTemp) = True Then Exit Function
	sTemp = Replace(sTemp, "&", "&amp;")
	sTemp = Replace(sTemp, "<", "&lt;")
	sTemp = Replace(sTemp, ">", "&gt;")
	sTemp = Replace(sTemp, Chr(34), "&quot;")
	inHTML = sTemp
End Function
%>