<%
'=======================================================
' 欢迎使用《阿赛大型门户网站系统V3.0》，简称“AsaiMHV3”
' 技术支持、商业版咨询、官方唯一指定联系QQ“4941172”
' 官方网站：http://77ya.com      程序负责人：阿赛
'=======================================================

'自动保存功能
dim sContentPath,rContentPath,nAllowSize,sAllowExt
'================================================
'作  用：'载入远程上传功能
'参  数：略
'================================================
Function DoRemoteUpload(UpCo,UpAS,UpAE,UpCD,UpIS)
    '为了节省空间，限制图片大小，如果超过nAllowSize，则不保存到本地
    nAllowSize = UpAS
    '图片类型限制，如果不是以下类型图片，则不保存到本地
    sAllowExt = UpAE
    '保存目录
    sContentPath=Cls.Web_Dir &Cls.Web_Upload &"/"& UpCD &"/"
	'日期目录
	If UpIS = 1 Then sContentPath = CreatePath(sContentPath) '按年月分类目录
	rContentPath=Replace(sContentPath,Cls.Web_Dir &Cls.Web_Upload &"/"& UpCD &"/","{$download_dir}/"& UpCD &"/")
	'执行保存
	DoRemoteUpload = ReplaceRemoteUrl(UpCO, sAllowExt)
End Function

'================================================
'作  用：替换字符串中的远程文件为本地文件并保存远程文件
'参  数：
'	sHTML: 要替换的字符串
'	sExt : 执行替换的扩展名
'================================================
Function ReplaceRemoteUrl(sHTML, sExt)
	Dim s_Content
	s_Content = sHTML
	If IsObjInstalled("Microsoft.XMLHTTP") = False then
		ReplaceRemoteUrl = s_Content
		Exit Function
	End If
    dim SaveFileName, SaveFileType
	Dim re, RemoteFile, RemoteFileurl
	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
	' 开始替换操作
	For i = 1 To n
		SaveFileType = Mid(a_RemoteUrl(i), InstrRev(a_RemoteUrl(i), ".") + 1)	
		SaveFileName = GetRndFileName(SaveFileType)	
		If SaveRemoteFile(SaveFileName, a_RemoteUrl(i)) = True Then
			's_Content = Replace(s_Content, a_RemoteUrl(i), sContentPath & SaveFileName, 1, -1, 1)
			s_Content = Replace(s_Content, a_RemoteUrl(i), rContentPath & SaveFileName, 1, -1, 1)
			'保存入数据库
			Call Cls.exec("insert into AsaiMHupload(UserName,UserIP,UpFileName,UpFileType,UpFileUrl,UpFileSize,UpFileTime) values('"&login_username&"','"&Cls.ip_sys(0)&"','"&SaveFileName&"','"&GetExt(SaveFileName)&"','"&rContentPath & SaveFileName&"','远程','"&Cls.now_time&"')",0)
		End If
	Next
	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("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("A"&"d"&"o"&"d"&"b"&"."&"S"&"t"&"r"&"e"&"a"&"m")	'防杀软误杀
		With Ads
			.Type = 1
			.Open
			.Write GetRemoteData
			.SaveToFile Server.MapPath(sContentPath&s_LocalFileName), 2
			.Cancel()
			.Close()
		End With
		Set Ads=nothing
	End If
	If Err.Number = 0 And bError = False Then
		SaveRemoteFile = True
	Else
		Err.Clear
	End If
End Function

'================================================
'作  用：检查组件是否已经安装
'参  数：strClassString ----组件名
'返回值：True  ----已经安装
'       False ----没有安装
'================================================
Function IsObjInstalled(strClassString)
	On Error Resume Next
	IsObjInstalled = False
	Err = 0
	Dim xTestObj
	Set xTestObj = Server.CreateObject(strClassString)
	If 0 = Err Then IsObjInstalled = True
	Set xTestObj = Nothing
	Err = 0
End Function

' 取随机文件名
Function GetRndFileName(sExt)
	Dim sRnd
	Randomize
	sRnd = Int(900 * Rnd) + 100
	GetRndFileName = year(now) & month(now) & day(now) & hour(now) & minute(now) & second(now) & sRnd & "." & sExt
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

Function GetExt(Getfilename)
	dim fname
	fname=split(Getfilename,".")
	GetExt=lcase(fname(1))
End Function
%>
