cls_down.asp

网络上经典的图片程序

<%
Class Download_Cls
	Private sUploadDir
	Private nAllowSize
	Private sAllowExt
	Private sOriginalFileName
	Private sSaveFileName
	Private sPathFileName

	Public Property Get RemoteFileName()
		RemoteFileName = sOriginalFileName
	End Property

	Public Property Get LocalFileName()
		LocalFileName = sSaveFileName
	End Property

	Public Property Get LocalFilePath()
		LocalFilePath = sPathFileName
	End Property

	Public Property Let RemoteDir(ByVal strDir)
		sUploadDir = strDir
	End Property

	Public Property Let AllowMaxSize(ByVal intSize)
		nAllowSize = intSize
	End Property

	Public Property Let AllowExtName(ByVal strExt)
		sAllowExt = strExt
	End Property

	Private Sub Class_Initialize()
		On Error Resume Next
		Script_Object = "Scripting.FileSystemObject"
		sUploadDir = "UploadFile/"
		nAllowSize = 500
		sAllowExt = "gif|jpg|png|bmp"
	End Sub

	Public Function ChangeRemote(sHTML)
		On Error Resume Next
		Dim s_Content
		s_Content = sHTML
		On Error Resume Next
		Dim re, s, 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}(" & sAllowExt & ")))"
		Set s = re.Execute(s_Content)
		Dim a_RemoteUrl(), n, i, bRepeat
		n = 0
		' 转入无重复数据
		For Each RemoteFileUrl In s
			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
		' 开始替换操作
		Dim nFileNum, sContentPath,strFilePath
		sContentPath = RelativePath2RootPath(sUploadDir)
		nFileNum = 0
		For i = 1 To n
			SaveFileType = Mid(a_RemoteUrl(i), InStrRev(a_RemoteUrl(i), ".") + 1)
			SaveFileName = GetRndFileName(SaveFileType)
			strFilePath = sUploadDir & SaveFileName
			If SaveRemoteFile(strFilePath, 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)
			End If
		Next

		ChangeRemote = s_Content
	End Function
	
	Public Function RelativePath2RootPath(url)
		Dim sTempUrl
		sTempUrl = url
		If Left(sTempUrl, 1) = "/" Then
			RelativePath2RootPath = sTempUrl
			Exit Function
		End If

		Dim sWebEditorPath
		sWebEditorPath = Request.ServerVariables("SCRIPT_NAME")
		sWebEditorPath = Left(sWebEditorPath, InStrRev(sWebEditorPath, "/") - 1)
		Do While Left(sTempUrl, 3) = "../"
			sTempUrl = Mid(sTempUrl, 4)
			sWebEditorPath = Left(sWebEditorPath, InStrRev(sWebEditorPath, "/") - 1)
		Loop
		RelativePath2RootPath = sWebEditorPath & "/" & sTempUrl
	End Function
	
	Public 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

	Public Function SaveRemoteFile(ByVal s_LocalFileName, ByVal s_RemoteFileUrl)
		Dim GetRemoteData
		Dim bError
		bError = False
		SaveRemoteFile = False
		On Error Resume Next
		Dim Retrieval
		Set Retrieval = CreateObject("MSXML2.XMLHTTP")
		With Retrieval
			.Open "GET", s_RemoteFileUrl, False, "", ""
			.setRequestHeader "Referer", s_RemoteFileUrl
			.send
			If .readyState <> 4 Then Exit Function
			If .Status > 300 Then Exit Function
			GetRemoteData = .responseBody
		End With
		Set Retrieval = Nothing
		If LenB(GetRemoteData) < 100 Then Exit Function
		Dim Ads
		Set Ads = Server.CreateObject("ADODB.Stream")
		With Ads
			.Type = 1
			.Open
			.Write GetRemoteData
			.SaveToFile Server.MapPath(s_LocalFileName), 2
			.Cancel
			.Close
		End With
		Set Ads = Nothing
		If Err.Number = 0 And bError = False Then
			SaveRemoteFile = True
		Else
			SaveRemoteFile = False
			Err.Clear
		End If
	End Function
End Class
%>