upload.asp

1.主要功能模块文章,图片,下载,商城,博客,论坛,留言,链接等 2.后台管理模块公告管理,广告系统,调查管理,用户管理,模板管理,短信管理, 评论管理,专题管理,采集管理,静态管理

'	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
			'服务器不支持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
		'Cls.InToColumn 
		'增加数据库信息
		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 strSetting(5)=1 Then
	       DrawInfo = strSetting(6)
	ElseIf strSetting(5)=2 Then
		   DrawInfo = Replace(strSetting(11),"{$web_dir}",Cls.Web_Dir)
		  'DrawInfo = strSetting(11)
	Else
		   DrawInfo = ""
	End If
	If DrawInfo = "" or Cls.Get_ChannelSetup(Cls.ChannelSetup,11)=0 Then strSetting(5) = 0
	Upload.UploadType			= strSetting(0)	'设置上传组件类型
	Upload.UploadPath			= sUploadDir					'设置上传路径
	Upload.InceptFileType		= Replace(sAllowExt,"|",",")'设置上传文件限制
	Upload.MaxSize				= Int(nAllowSize)		'单位 KB
	Upload.InceptMaxFile		= 10						'每次上传文件个数上限
	'Upload.ChkSessionName		= "UploadCode"&sChannelID&UpFileType'防止重复提交。
	Upload.IsReName             = sIsReName                '是否重命名。
	Upload.PreviewType			= strSetting(1)	        '设置预览图片组件类型
	Upload.PreviewImageWidth	= strSetting(2)		    '设置预览图片宽度
	Upload.PreviewImageHeight	= strSetting(3)		    '设置预览图片高度
	Upload.DrawImageWidth		= strSetting(14)		'设置水印图片或文字区域宽度
	Upload.DrawImageHeight		= strSetting(15)		'设置水印图片或文字区域高度
	Upload.DrawGraph			= strSetting(12)		'设置水印透明度
	Upload.DrawFontColor		= "#"&strSetting(8)			'设置水印文字颜色
	Upload.DrawFontFamily		= strSetting(9)			'设置水印文字字体格式
	Upload.DrawFontSize			= strSetting(7)			'设置水印文字字体大小
	Upload.DrawFontBold			= strSetting(10)		'设置水印文字是否粗体
	Upload.DrawInfo				= DrawInfo				'设置水印文字信息或图片信息
	Upload.DrawType				= strSetting(5)			'0=不加载水印 ，1=加载水印文字，2=加载水印图片
	Upload.DrawXYType			= strSetting(16)		'"0" =左上，"1"=左下,"2"=居中,"3"=右上,"4"=右下
	Upload.DrawSizeType			= strSetting(4)		    '"0"=固定缩小，"1"=等比例缩小
	If strSetting(13)<>"" Then
		Upload.TransitionColor	= "#"&strSetting(13)		'透明度颜色设置
	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
'检测用户每日上传文件数量。
Function Up_Today_Num()
  If Login_Mode = "admin" Then 
     Up_Today_Num = True
	 Exit Function
  Else
     If Login_Username = "" Then
        Up_Today_Num=false
	    Exit Function
     End If
  End If
  dim ta
  ta="#"
  if SqlType=1 then ta="'"
  Up_Today_Num=true
  sql="select count(*) from DB_Upload where UserName='"&login_username&"' and UpFileTime>="&ta&formatdatetime(formatdatetime(Cls.now_time,2))&ta
  set rs=Cls.exec(sql,1)
  Today_num=rs(0)
  rs.close
  if not(isnumeric(Today_num)) then Today_num=0
  if int(Today_num)>=int(UserGroup_Config(18)) then
   Up_Today_Num=false
  end if
end Function
'按月份自动明名上传文件夹,需要ＦＳＯ组件支持。
Private Function CreatePath(PathValue)
	Dim objFSO,uploadpath
	uploadpath=year(now)&"-"&month(now)	'以年月创建上传文件夹，格式：2003－8
	If Right(PathValue,1)<>"/" Then PathValue = PathValue&"/"
	On Error Resume Next
	Set objFSO = Server.CreateObject("Scripting.FileSystemObject")
		If objFSO.FolderExists(Server.MapPath(PathValue))=False Then
			objFSO.CreateFolder Server.MapPath(PathValue)
		End If
		If objFSO.FolderExists(Server.MapPath(PathValue & uploadpath))=False Then
			objFSO.CreateFolder Server.MapPath(PathValue & uploadpath)
		End If
		If Err.Number = 0 Then
			CreatePath = PathValue & uploadpath & "/"
		Else
			CreatePath = PathValue
		End If
	Set objFSO = Nothing
End Function
%>