<%@ language=VBScript CODEPAGE=936%>
<%
Option Explicit
response.buffer= True
'<!--#include file = "Conn.asp"-->
%>
<!--#include file = "../Conn.asp"-->
<!--#include file = "../Inc/Cl_ClsSysTem.asp"-->
<!--#include file = "../Inc/Cl_ClsUpFile.asp"-->
<%
Cl.Page_Admin	= True
Cl.GetWeb_Setting()
if Not Cl.ChkUserLogin then
	Cl.OutErr("<br /><li>您无此操作权限！</li>")
end if
Server.ScriptTimeOut = 999999
' 参数变量
Dim sType, sStyleName, sTrSetting
Dim sChannelID, IsTrueUpfiles 
'频道ID，允许上传权限
' 设置变量
Dim sAllowExt, nAllowSize, sIsReName, sUploadDir, sPreviewpath, nUploadObject, nAutoDir, sBaseUrl, sContentPath
' 接口变量
Dim sFileExt, oFileSize, sOriginalFileName, sSaveFileName, sPathFileName, nFileNum

dim strJs
Dim Upload,FormName,FilePath,ChildFilePath
Dim File,F_FileName,F_ViewName,F_Filesize,F_FileExt,F_Type
Dim DrawInfo
Dim sTObj

Call InitUpload()	' 初始化上传变量

Dim sAction
sAction = UCase(Trim(Request.QueryString("action")))

Select Case sAction
Case "REMOTE"
	Call DoRemote()			' 远程自动获取
Case "SAVE"
	Call ShowForm()			' 显示上传表单
	Call DoSave()			' 存文件
Case Else
	Call ShowForm()			' 显示上传表单
End Select

Sub ShowForm() 
%>
<HTML>
<HEAD>
<TITLE>文件上传</TITLE>
<meta http-equiv="Content-Type" content="text/html; charset=gb2312">
<style type="text/css">
body, a, table, div, span, td, th, input, select{font:9pt;font-family: "宋体", Verdana, Arial, Helvetica, sans-serif;}
body {padding:0px;margin:0px}
</style>
<script language="JavaScript" src="dialog/dialog.js"></script>
</head>
<body bgcolor=menu>
<form action="Upload.asp?action=save&cid=<%=sChannelID%>&type=<%=sType%>&style=<%=sStyleName%>&TObj=<%=sTObj%>" method=post name=myform enctype="multipart/form-data">
<input type=file name=uploadfile size=1 style="width:100%" onchange="originalfile.value=this.value;SelectOnchange(this.value);">
<input type=hidden name=originalfile value="">
</form>
<script language="JavaScript" type="text/javascript">

var sAllowExt = "<%=sAllowExt%>";
// 检测上传表单
function CheckUploadForm() {
	if (!IsExt(document.myform.uploadfile.value,sAllowExt)){
		parent.UploadError("提示：\n\n请选择一个有效的文件，\n支持的格式有（"+sAllowExt+"）！");
		return false;
	}
	return true
}

// 提交事件加入检测表单
var oForm = document.myform ;
oForm.attachEvent("onsubmit", CheckUploadForm) ;
if (! oForm.submitUpload) oForm.submitUpload = new Array() ;
oForm.submitUpload[oForm.submitUpload.length] = CheckUploadForm ;
if (! oForm.originalSubmit) {
	oForm.originalSubmit = oForm.submit ;
	oForm.submit = function() {
		if (this.submitUpload) {
			for (var i = 0 ; i < this.submitUpload.length ; i++) {
				this.submitUpload[i]() ;
			}
		}
		this.originalSubmit() ;
	}
}

// 上传表单已装入完成
try {
	parent.UploadLoaded();
}
catch(e){
}

function SelectOnchange(sfile){
	var sType = "<%=sType%>";
	if ((IsExt(sfile,'gif|bmp|jpg|png')) && (sType=="IMAGE")){
		parent.doPreview();
	}
}
</script>

</body>
</html>
<% 
End Sub 

' 保存操作
Sub DoSave()
	Set Upload = New UpFile_Cls
	InitUpLoad_Cls
	Upload.SaveUpFile
	If Upload.ErrCodes<>0 Then
		Call OutScript("parent.UploadError('错误："& Upload.Description &"')")
		Response.End
	End If
	strJs=""
	On Error Resume Next
	If Upload.Count > 0 Then
		For Each FormName In Upload.UploadFiles
			Set File = Upload.UploadFiles(FormName)
			sSaveFileName = File.FileName
			F_FileName = sUploadDir & sSaveFileName
			sPathFileName = sContentPath & sSaveFileName
			'创建预览及水印图片
			If Upload.PreviewType<>999 and File.FileType=1 then
				F_Viewname = sPreviewpath & "pre" & Replace(File.FileName,File.FileExt,"") & "jpg"
				Upload.CreateView F_FileName,F_Viewname,File.FileExt
			End If
			strJs=strJs&"parent.UploadSaved('" & sPathFileName & "');var obj=parent.dialogArguments.dialogArguments;if (!obj) obj=parent.dialogArguments;try{obj.addUploadFile('" & File.OldFileName & "', '" & sSaveFileName & "', '" & sPathFileName & "');"'} catch(e){};"
			if Lcase(left(sPathFileName,Len(Cl.UpLoadDir)))=Lcase(Cl.UpLoadDir) then
				sPathFileName="{%uploaddir%}" & mid(sPathFileName,Len(Cl.UpLoadDir)+1) 
			elseif left(sPathFileName,1)="/" then
				sPathFileName="{%webdir%}" & mid(sPathFileName,2)
			else
				sPathFileName=Trim(sPathFileName)
			end if
			strJs=strJs & "obj.AddUploadFiles('"&sTObj&"','" & sPathFileName & "','" & sPathFileName & "');} catch(e){};"
			Cl.InToColumn "Cl_UpFileLog","UserID,UserName,UserLevel,UserIP,UpFileName,SaveFileName,UpFileTime,ChannelID,IsUse","'"&Cl.User_Info(4)&"','"&Cl.User_Info(5)&"','"&Cl.User_Info(21)&"','"&Cl.UserTrueIP&"','"&File.OldFileName&"','"&sPathFileName&"','"&Now&"',"&sChannelID&",1"
			Set File = Nothing
		Next
		Call OutScript(strJs)
	Else
		Call OutScript("parent.UploadError('请正确选择要上传的文件。')")
		Response.End
	End If
	Set Upload = Nothing

End Sub

' 自动获取远程文件
Sub DoRemote()
	Dim sContent, i
	For i = 1 To Request.Form("Editor_UploadText").Count 
		sContent = sContent & Request.Form("Editor_UploadText")(i) 
	Next
	If sAllowExt <> "" Then
		sContent = ReplaceRemoteUrl(sContent, sAllowExt)
	End If

	Response.Write "<HTML><HEAD><TITLE>远程上传</TITLE><meta http-equiv='Content-Type' content='text/html; charset=gb2312'></head><body>" & _
		"<input type=hidden id=UploadText value=""" & inHTML(sContent) & """>" & _
		"</body></html>"

	Call OutScriptNoBack("parent.setHTML(UploadText.value);try{parent.addUploadFile('" & sOriginalFileName & "', '" & sSaveFileName & "', '" & sPathFileName & "');} catch(e){} parent.remoteUploadOK();")

End Sub
' 输出客户端脚本
Sub OutScript(str)
	Response.Write "<script type=""text/javascript"">" & str & ";history.back()</script>"
End Sub
Sub OutScriptNoBack(str)
	Response.Write "<script type=""text/javascript"">" & str & "</script>"
End Sub

' 初始化上传限制数据
Sub InitUpload()
	sType		= UCase(Trim(Request.QueryString("type")))
	sTObj		= Trim(Request.QueryString("TObj"))
	sChannelID	= Trim(Request.QueryString("cid"))
	if Not IsNumeric(sChannelID) or sChannelID="" then
		OutScript("parent.UploadError('错误，请通过页面上的链接进行操作！')")
		Exit Sub
	end if
	Cl.GetChannelSetting(sChannelID)
	sStyleName		= Cl.Checkstr(Trim(Request.QueryString("style")))
	sTrSetting		= Split(Cl.Channel_Setting(22),"@")
	IsTrueUpfiles	= Trim(sTrSetting(0))		'允许上传权限
	'判断上传文件权限
	if Not Cl.ChkUserLevel(IsTrueUpfiles,Cl.UserLevel) then
		OutScript("parent.UploadError('本频道上传功能已禁用或者你无上传文件权限！')")
		Exit Sub
	end if
	sUploadDir		= Trim(sTrSetting(1))        '上传目录
	nAutoDir		= Cint(sTrSetting(2))			'自动分类 0不使用，1按年，2年-月，3年-月-日
	sPreviewpath	= Replace(Cl.UpLoadDir & "/PreviewImage/" & sUploadDir & "/","//","/")
	sUploadDir		= Replace(Cl.UpLoadDir & "/" & sUploadDir & "/","//","/")
	sUploadDir		= Cl.CreatePath(sUploadDir,nAutoDir)
	sPreviewpath	= Cl.CreatePath(sPreviewpath,nAutoDir) '按年月分类目录
	sContentPath	= sUploadDir'Cl.RelativePath2RootPath(sUploadDir)
	if sTrSetting(3)="1" then
		sContentPath = Cl.RootPath2DomainPath(sContentPath)
	end if
	Select Case sType
	Case "FILE"
		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 = Mid(a_RemoteUrl(i), InstrRev(a_RemoteUrl(i), "/") + 1)
		else
			SaveFileName = Upload.NewFileName(SaveFileType)
		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,UserLevel,UserIP,UpFileName,SaveFileName,UpFileTime,ChannelID,IsUse","'"&Cl.User_Info(4)&"','"&Cl.User_Info(5)&"','"&Cl.User_Info(21)&"','"&Cl.UserTrueIP&"','"&s_RemoteFileUrl&"','"&sUploadDir & s_LocalFileName&"','"&Now&"',"&sChannelID&",1"
		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
%>
