functions_upload.asp

简单的asp论坛源码系统,很适用于初学者!界面简洁,功能齐全

		'***     AspSimpleUpload component     ****
		'******************************************

		'ASPSimpleUpload component
		Case "AspSimple"

			'Dimension variables
			Dim file	'Holds the FSO file object

			'Set error trapping
			On Error Resume Next

			'Create upload object
			Set objUpload = Server.CreateObject("ASPSimpleUpload.Upload")
			
			'Check to see if an error has occurred
			'If an error has occurred write an error to the page
			If Err.Number <> 0 Then	Call errorMsg("An error has occurred while uploading file/image.<br />Please check the ASPSimpleUpload is installed on the server.", "create_AspSimpleUpload_object", "functions_upload.asp")
		
			'Disable error trapping
			On Error goto 0
			
			With objUpload

				'Get the file name
				strOriginalFileName = .ExtractFileName(.Form("file"))

				'Save the amended file name
				strNewFileName = "TMP" & hexValue(7) & "_" & strOriginalFileName
				
				'Filter file name to remove anything that isn't allowed by the filters
				strNewFileName = formatFileName(strNewFileName)

				'Save the file to disk first so we can check it
				Call .SaveToWeb ("file", strUploadFilePath & "\" & strNewFileName)

				'Create the file system object
				Set objFSO = Server.CreateObject("Scripting.FileSystemObject")

				'Create a file object with the file details
				Set file = objFSO.GetFile(Server.MapPath(strUploadFilePath) & "\" & strNewFileName)

				'Check the file size is not above the max allowed size, this is done using a function not the compoent to stop an exception error
				lngErrorFileSize = fileSize(file.Size, lngMaxFileSize)


				'Place the original file name back in the new filename variable
				strNewFileName = strOriginalFileName
				
				'Filter file name to remove anything that isn't allowed by the filters
				strNewFileName = formatFileName(strNewFileName)


				'Loop through all the allowed extensions and see if the file has one
				blnExtensionOK = fileExtension(strNewFileName, saryFileUploadTypes)

				'Check if file exsists
				blnFileExists = objFSO.FileExists(Server.MapPath(strUploadFilePath) & "\" & strNewFileName)

				'If the file is OK save it to disk
				If lngErrorFileSize = 0 AND blnExtensionOK AND blnFileExists = False Then

					'Save the file to disk
					Call .SaveToWeb("file", strUploadFilePath & "/" & strNewFileName)

					'Pass the filename back
					fileUpload = strNewFileName
				End If
				
				'Delete the original file
				file.Delete

			End With

			'Clean up
			Set file = Nothing
			Set objFSO = Nothing
			Set objUpload = Nothing

	End Select
	
	
	
	
	'******************************************
	'***  Security check for MIME change   ****
	'******************************************
	
	'Read in the uploaded file to make sure that the user is not trying to sneak through a change of content type in an image etc.
	
	'Get the file extension
	If InStr(strNewFileName, ".") Then
		strExtension = Mid(strNewFileName, InStrRev(strNewFileName, "."), 5)
	Else
		strExtension = "."
	End If
	
	'Don't run if text based file
	If strExtension <> ".txt" AND strExtension <> ".text" AND strExtension <> ".xml" AND strExtension <> ".css" AND strExtension <> ".htm" AND strExtension <> ".html" Then
	
		'Create the file system object
		Set objFSO = Server.CreateObject("Scripting.FileSystemObject")
	
		'Check to make sure file exsists
		If objFSO.FileExists(Server.MapPath(strUploadFilePath) & "\" & strNewFileName) Then
			
			'Create a file object with the file details
			Set file = objFSO.GetFile(Server.MapPath(strUploadFilePath) & "\" & strNewFileName)
			
			' Open the file for reading (1) as an ascii file (0)
			Set objTextStream = file.OpenAsTextStream(1, 0)
		
			'Read in line by line and check the content type is not altered
			Do While Not objTextStream.AtEndOfStream
				strTempFile = strTempFile & objTextStream.readline
			Loop
			
			'Clean up (done now to prevent a permissions error later)
			Set objTextStream = nothing
			
			'Trim and set as lower case
			strTempFile = Trim(strTempFile)
			
			'For adobe created files
			If InStr(strTempFile, "adobe:ns:meta") Then
				strTempFile = Replace(strTempFile, "DocumentID", "", 1, -1, 0)
				strTempFile = Replace(strTempFile, "Description", "", 1, -1, 0)
				strTempFile = Replace(strTempFile, "CreateDate", "", 1, -1, 0)
			End If
			
			'LCase
			strTempFile = LCase(strTempFile)
			
			'Remove spaces and tabs
			strTempFile = Replace(strTempFile, Chr(9), "", 1, -1, 1) 'Tabs
			strTempFile = Replace(strTempFile, " ", "", 1, -1, 1)
			
			%><!--#include file="unsafe_upload_content_inc.asp" --><%
			
			'See if the file is attempting to change the content type
			If InStr(strTempFile, "contenttype") Then 
				blnExtensionOK = False
				
			ElseIf InStr(strTempFile, "content-type") Then 
				blnExtensionOK = False
				
			ElseIf InStr(strTempFile, "addtype") Then 
				blnExtensionOK = False
				
			ElseIf InStr(strTempFile, "doctype") Then 
				blnExtensionOK = False

			'If the file type is an image do some futher checking
			ElseIf strExtension = ".gif" OR strExtension = ".jpg" OR strExtension = ".png" OR strExtension = ".jpeg" OR strExtension = ".jpe" OR strExtension = ".tiff" OR strExtension = ".bmp" Then
				
				'Loop through the array of disallowed HTML tags
				For lngLoopCounter = LBound(saryUnSafeHTMLtags) To UBound(saryUnSafeHTMLtags)
						
					'If the disallowed HTML is found remove it and start over
					If Instr(1, strTempFile,  saryUnSafeHTMLtags(lngLoopCounter), 1) Then
						blnExtensionOK = False
					End If
				Next
			End If
			
			'If the file extension is not OK then delete file
			If blnExtensionOK = False Then file.Delete
				
			
		End If
		
		'Clean up
		Set file = Nothing
		Set objFSO = Nothing
	End If

End Function





'******************************************
'***	Check file size function       ****
'******************************************
Function fileSize(ByVal lngFileSize, ByVal lngMaxFileSize)

	'If the file size is to large place the present file size in then return the file size
	If CLng(lngFileSize / 1024) > lngMaxFileSize Then

		fileSize = CLng(lngFileSize / 1024)

	'Else set the return value to 0
	Else
		fileSize = 0
	End If

End Function





'******************************************
'***	Check file ext. function       ****
'******************************************
Function fileExtension(ByVal strFileName, ByVal saryFileUploadTypes)

	'Dimension varibles
	Dim intExtensionLoopCounter

	'Intilaise return value
	fileExtension = False

	'Loop through all the allowed extensions and see if the file has one
	For intExtensionLoopCounter = 0 To UBound(saryFileUploadTypes)

		If LCase(Right(strFileName, Len(saryFileUploadTypes(intExtensionLoopCounter)))) = LCase(saryFileUploadTypes(intExtensionLoopCounter)) Then fileExtension = True
	Next

End Function





'******************************************
'***	Format file names      	       ****
'******************************************
'Format file names to strip caharacters that will otherwise be stripped by the filters producing dead links
Private Function formatFileName(ByVal strInputEntry)

	'Dimension variable
	Dim intLoopCounter 	'Holds the loop counter

	'Loop through the ASCII characters 0 to 31
	For intLoopCounter = 0 to 31
		strInputEntry = Replace(strInputEntry, CHR(intLoopCounter), "", 1, -1, 0)
	Next
	
	'Windows illegal filename characters
	strInputEntry = Replace(strInputEntry, "/", "", 1, -1, 0)
	strInputEntry = Replace(strInputEntry, "\", "", 1, -1, 0)
	strInputEntry = Replace(strInputEntry, ":", "", 1, -1, 0)
	strInputEntry = Replace(strInputEntry, "*", "", 1, -1, 0)
	strInputEntry = Replace(strInputEntry, "?", "", 1, -1, 0)
	strInputEntry = Replace(strInputEntry, """", "", 1, -1, 0)
	strInputEntry = Replace(strInputEntry, "<", "", 1, -1, 0)
	strInputEntry = Replace(strInputEntry, ">", "", 1, -1, 0)
	strInputEntry = Replace(strInputEntry, "|", "", 1, -1, 0)

	'Others that are striped by the filters
	strInputEntry = Replace(strInputEntry, " ", "_", 1, -1, 1)
	strInputEntry = Replace(strInputEntry, ",", "", 1, -1, 1)
	strInputEntry = Replace(strInputEntry, "[", "", 1, -1, 1)
	strInputEntry = Replace(strInputEntry, "]", "", 1, -1, 1)
	strInputEntry = Replace(strInputEntry, "(", "", 1, -1, 1)
	strInputEntry = Replace(strInputEntry, ")", "", 1, -1, 1)
	strInputEntry = Replace(strInputEntry, "{", "", 1, -1, 1)
	strInputEntry = Replace(strInputEntry, "}", "", 1, -1, 1)
	strInputEntry = Replace(strInputEntry, "'", "", 1, -1, 1)

	'Return
	formatFileName = strInputEntry
End Function





'**********************************************
'***   Create a folder for uploads 	   ****
'**********************************************

Private Sub createUserFolder(ByVal strFolder)	

	Dim objFSO
	Dim objUserXMLfile
	Dim strFolderUserName
	Dim lngFolderUserID
	
	'Set error trapping
	On Error Resume Next
		
	'Creat an instance of the FSO object
	Set objFSO = Server.CreateObject("Scripting.FileSystemObject")
	
	'Check to see if an error has occurred
	'If an error has occurred write an error to the page
	If Err.Number <> 0 Then	Call errorMsg("An error has occurred while uploading file/image.<br />Please check the File System Object (FSO) is installed on the server.", "create_FSO_object", "functions_upload.asp")

	'Disable error trapping
	On Error goto 0
	
	'If a folder doesn't exist for this user create one
	If NOT objFSO.FolderExists(Server.MapPath(strFolder)) Then
		
		'Get the user ID from the end of the file path
		lngFolderUserID = CLng(Right(strFolder, (Len(strFolder) - Instr(strFolder, "/"))))
		
		
		'If the user dosen't have a folder create them one
		'Make sure the folder doesn't already exsist (we already do this above, but some people still get an error, so we do it again)
		If Not objFSO.FolderExists(Server.MapPath(strFolder)) Then objFSO.CreateFolder(Server.MapPath(strFolder))
		
		
		'Read in the username of this user from the database as it is needed for the XML file containing data on the folder
		strSQL = "SELECT " & strDbTable & "Author.Username " & _
		"FROM " & strDbTable & "Author" & strDBNoLock & " " & _
		"WHERE " & strDbTable & "Author.Author_ID = " & lngFolderUserID & ";"
	
		'Query the database
		rsCommon.Open strSQL, adoCon
		
		If NOT rsCommon.EOF Then strFolderUserName = rsCommon("Username")
		
		'Close RS
		rsCommon.Close
		
		
		'Create an XML file with user details; TODO, add feature to be able to add notes
		Set objUserXMLfile = objFSO.CreateTextFile(Server.MapPath(strFolder) & "\folder_info.xml", True) 
		
		'Add Contents
		objUserXMLfile.WriteLine("<?xml version=""1.0"" encoding=""utf-8""?>" & _
				vbCrLf & "<folder>" & _
				vbCrLf & " <created>" & internationalDateTime(Now()) & "</created>" & _
				vbCrLf & " <owner>" & _
				vbCrLf & "  <uid>" & lngFolderUserID & "</uid>" & _
				vbCrLf & "  <username>" & strFolderUserName & "</username>" & _
				vbCrLf & " </owner>" & _
				vbCrLf & "</folder>")
		
		'Close
		objUserXMLfile.Close
		Set objUserXMLfile = Nothing
		
	End If
	
	'Release the FSO object
	Set objFSO = Nothing
	
End Sub




'**********************************************
'***   Check if user has upload folder   ****
'**********************************************

Private Function userUploadFolder(ByVal strFolder)	

	Dim objFSO
	
	'Set error trapping
	On Error Resume Next
		
	'Creat an instance of the FSO object
	Set objFSO = Server.CreateObject("Scripting.FileSystemObject")
	
	'Check to see if an error has occurred
	'If an error has occurred write an error to the page
	If Err.Number <> 0 Then	Call errorMsg("An error has occurred while uploading file/image.<br />Please check the File System Object (FSO) is installed on the server.", "create_FSO_object", "functions_upload.asp")

	'Disable error trapping
	On Error goto 0
	
	'If a folder doesn't exist for this user create one
	If objFSO.FolderExists(Server.MapPath(strFolder)) Then
		
		userUploadFolder = True
	Else
		userUploadFolder = False
		
	End If
	
	'Release the FSO object
	Set objFSO = Nothing
End Function




'**********************************************
'***  Check allocated space   ****
'**********************************************

Private Function folderSize(ByVal strFolder)	

	Dim objFSO
	
	'Set error trapping
	On Error Resume Next
		
	'Creat an instance of the FSO object
	Set objFSO = Server.CreateObject("Scripting.FileSystemObject")
	
	'Check to see if an error has occurred
	'If an error has occurred write an error to the page
	If Err.Number <> 0 Then	Call errorMsg("An error has occurred while uploading file/image.<br />Please check the File System Object (FSO) is installed on the server.", "create_FSO_object", "functions_upload.asp")

	'Disable error trapping
	On Error goto 0
	
	'Now lets check the size of the folder (it's returned in bytes so converet to MB with 2 decimal places)
	folderSize = FormatNumber(CDbl(objFSO.GetFolder(Server.MapPath(strFolder)).Size / 1024 / 1024), 2)
	
	
	'Release the FSO object
	Set objFSO = Nothing
	
End Function
%>