Uploading Files with ASP

Option Explicit

'Error Definitions
Private Const ERR_FILESIZE_NOT_ALLOWED As Long = vbObjectError + 103
Private Const ERR_FOLDER_DOES_NOT_EXIST As Long = vbObjectError + 104
Private Const ERR_FILE_ALREADY_EXISTS As Long = vbObjectError + 105
Private Const ERR_FILE_TYPE_NOT_ALLOWED As Long = vbObjectError + 106

Private varFileData As Variant
Private cData       As Collection

'*****************************************************************
' Add()
' Purpose:  Adds an item to the field collection
' Inputs:   strKey   -- the item's key
'           strValue     -- string containing the value
'*****************************************************************
Friend Sub Add(ByVal strKey As String, ByVal strValue As String)
    cData.Add strValue, strKey
End Sub

'*****************************************************************
' FileData()
' Purpose:  Sets the contents of a file
' Inputs:   varContent   -- the content of the file
'*****************************************************************

Friend Property Let FileData(varContent As Variant)
    varFileData = varContent
End Property

'*****************************************************************
' Properties
' Purpose:  Returns various public values
'*****************************************************************
Public Property Get Value() As String
    Value = GetVal("FileName")
End Property
Public Property Get FileSize() As String
    FileSize = GetVal("FileLen")
End Property
Public Property Get Name() As String
    Name = GetVal("Name")
End Property
Public Property Get ContentType() As String
    ContentType = GetVal("ContentType")
End Property
Public Property Get IsFile() As Boolean
    IsFile = Exists("FileName")
End Property

'*****************************************************************
' Private Functions
'*****************************************************************

Private Sub Class_Initialize()
    Set cData = New Collection
End Sub
Private Function GetVal(ByVal strKey As String) As String
    If Exists(strKey) Then
        GetVal = cData(strKey)
    Else
        GetVal = cData("Value")
    End If
End Function
Private Function Exists(ByVal strKey As String) As Boolean
    Dim strDummy As String
    On Error Resume Next
    strDummy = cData(strKey)
    If Err = 0 Then Exists = True
End Function


'*****************************************************************
' SaveFile()
' Purpose:  Saves the form entry to a file (if it is one)
' Inputs:   strUploadPath   -- string containing the directory to upload to
'           strFileName     -- string containing the filename
'           strExcludeFileExtensions -- file extensions to exclude
'*****************************************************************
Public Sub SaveFile(ByVal strUploadPath As String, ByVal strFileName As String, Optional ByVal strExcludeFileExtensions As String = "", Optional ByVal lMaxByteCount As Long = 0)
    'we can only save files...
    If IsFile = False Then Exit Sub
    If strFileName = "" Then strFileName = cData("FileName")
    'Check to see if file extensions are excluded
    If strExcludeFileExtensions <> "" Then
        If ValidFileExtension(strFileName, strExcludeFileExtensions) Then
            Err.Raise ERR_FILE_TYPE_NOT_ALLOWED, "ASPUploadComponent", "It is not allowed to upload a file containing a [." & GetFileExtension(strFileName) & "] extension"
        End If
    End If

    'Check for maximum bytes allowed
    If Not lMaxByteCount = 0 Then
        If lMaxByteCount < FileSize() Then
            Err.Raise ERR_FILESIZE_NOT_ALLOWED, "ASPUploadComponent", "File size exceeds maximum size specified"
        End If
    End If

    WriteFile strUploadPath, strFileName
End Sub

'*****************************************************************
' WriteFile()
' Purpose:  Writes the uploaded file to a given directory
' Inputs:   strUploadPath   -- string containing the directory to upload to
'           strFileName     -- string containing the filename
'*****************************************************************
Private Sub WriteFile(ByVal strUploadPath As String, ByVal strFileName As String)

On Error GoTo WriteFile_Err

    'Variables for file
    Dim fs As Scripting.FileSystemObject
    Set fs = New Scripting.FileSystemObject
   
    Dim sFile As Object
   
    If Not Right(strUploadPath, 1) = "\" Then
        strUploadPath = strUploadPath & "\"
    End If
   
    If Not fs.FolderExists(strUploadPath) Then
        Err.Raise ERR_FOLDER_DOES_NOT_EXIST, "ASPUploadComponent", "The folder to upload to doesn't exist"
    End If
   
    If fs.FileExists(strUploadPath & strFileName) Then
        Err.Raise ERR_FILE_ALREADY_EXISTS, "ASPUploadComponent", "The file [" & strFileName & "] already exists."
    End If
   
    'Create file
    Set sFile = fs.CreateTextFile(strUploadPath & strFileName, True)
   
    'Write file
    sFile.Write varFileData
   
    'Close File
    sFile.Close
   
    Set sFile = Nothing
    Set fs = Nothing

    Exit Sub

WriteFile_Err:

    Err.Raise Err.Number

End Sub
'*****************************************************************
' ValidFileExtension()
' Purpose:  Checks if the file extension is allowed
' Inputs:   strFileName -- the filename
'           strFileExtension -- the fileextensions not allowed
' Returns:  boolean
'*****************************************************************

Private Function ValidFileExtension(ByVal strFileName As String, Optional ByVal strFileExtensions As String = "") As Boolean

    Dim arrExtension() As String
    Dim strFileExtension As String
    Dim i As Integer
   
    strFileExtension = UCase(GetFileExtension(strFileName))
   
    arrExtension = Split(UCase(strFileExtensions), ";")
   
    For i = 0 To UBound(arrExtension)
       
        'Check to see if a "dot" exists
        If Left(arrExtension(i), 1) = "." Then
            arrExtension(i) = Replace(arrExtension(i), ".", vbNullString)
        End If
       
        'Check to see if FileExtension is allowed
        If arrExtension(i) = strFileExtension Then
            ValidFileExtension = True
            Exit Function
        End If
       
    Next
   
    ValidFileExtension = False

End Function


'*****************************************************************
' GetFileExtension()
' Purpose:  Returns the extension of a filename
' Inputs:   strFileName     -- string containing the filename
'           varContent      -- variant containing the filedata
' Outputs:  a string containing the fileextension
'*****************************************************************

Private Function GetFileExtension(strFileName) As String

    GetFileExtension = Mid(strFileName, InStrRev(strFileName, ".") + 1)
   
End Function