troubleshooting Question

FreeASPUpload - Need help preventing overwrite

Avatar of brainbolt
brainbolt asked on
19 Comments2 Solutions1805 ViewsLast Modified:
I need help tweaking freeASPUpload (  

I've been able to modifiy it  to insert additional text fields to an Access DB while the file is uploaded, but I need to put in some overwrite protection. Currently, if a user uploads a file with a duplicate name, the older file is overwritten, which is unacceptable for this application.

I'm open to either checking if the filename already exists in the destination folder and stopping the upload process, or renaming the file if a duplicate name is found, but I haven't been able to succesfully implement either one of those options. I am new to ASP, so please bear with me.

Here are my files:

uploadTester3.asp - modified version of uploadTester.asp
************* START UPLOADTESTER3.ASP *******************

option explicit
Response.Expires = -1
Server.ScriptTimeout = 600

<!-- #include file="freeaspupload.asp" -->

dim SONum

' ****************************************************
' Change the value of the variable below to the pathname
' of a directory with write permissions, for example "C:\Inetpub\wwwroot"
Dim uploadsDirVar
  uploadsDirVar = "e:\shared\sodocs\" & SONum & "\"
' ****************************************************

' Note: this file uploadTester.asp is just an example to demonstrate
' the capabilities of the freeASPUpload.asp class. There are no plans
' to add any new features to uploadTester.asp itself. Feel free to add
' your own code. If you are building a content management system, you
' may also want to consider this script:

function OutputForm()
<h2 align="center">Upload new document for <% = SONum %></h2>
<div align=center>
    <form name="frmSend" method="POST" enctype="multipart/form-data" action="" onSubmit="return onSubmitForm();">
<input type="hidden" name="dupdate" value="<% = date & " " & time %>">
<input type="hidden" name="csono_trim" value=<% = SONum %>>
      Click "Browse" to locate the files to upload<br>
&nbsp;<table border="1" id="table1" bordercolordark="#000000" cellspacing="0">
            <tr bgcolor="#E5E5E5">
                  <td> <input name="filename" type="file" size=35></td>
                  <td><select size="1" name="doctype">
                  <option value="DRAWING">Drawing</option>
                  <option value="PROPOSAL">Proposal</option>
                  <option value="FRTQUOTE">Freight Quote</option>
                  <option value="SGNDRAWING">Signed Drawing</option>
                  <option value="SGNPROPOSA">Signed Proposal</option>
                  <option value="SGNTERMS">Signed Terms</option>
                  <option value="SGNINSTALL">Signed Install Waiver</option>
                  <option value="PACKLIST">Packing List</option>
                  <option value="FRTBILL">Bill Of Lading</option>
                  <option value="PUNCHSO">Punch SO</option>
                  <td> <input name="docnotes" type="text" size=35></td>
    <input style="margin-top:4" type=submit value="Upload">

end function

function TestEnvironment()
Dim fso, fileName, testFile, streamTest
TestEnvironment = ""
Set fso = Server.CreateObject("Scripting.FileSystemObject")
if not fso.FolderExists(uploadsDirVar) then
        'TestEnvironment = "<div align=center><B>Folder " & uploadsDirVar & " does not exist.</B><br>The value of your uploadsDirVar is incorrect. Open uploadTester.asp in an editor and change the value of uploadsDirVar to the pathname of a directory with write permissions.</div>"
        'exit function
end if

fileName = uploadsDirVar & "\test.txt"
on error resume next
Set testFile = fso.CreateTextFile(fileName, true)
If Err.Number<>0 then
TestEnvironment = "<B>Folder " & uploadsDirVar & " does not have write permissions.</B><br>The value of your uploadsDirVar is incorrect. Open uploadTester.asp in an editor and change the value of uploadsDirVar to the pathname of a directory with write permissions."
exit function
end if

If Err.Number<>0 then
TestEnvironment = "<B>Folder " & uploadsDirVar & " does not have delete permissions</B>, although it does have write permissions.<br>Change the permissions for IUSR_<I>computername</I> on this folder."
exit function
end if
Set streamTest = Server.CreateObject("ADODB.Stream")
If Err.Number<>0 then
TestEnvironment = "<B>The ADODB object <I>Stream</I> is not available in your server.</B><br>Check the Requirements page for information about upgrading your ADODB libraries."
exit function
end if
Set streamTest = Nothing
end function

function SaveFiles
Dim Upload, fileName, fileSize, ks, i, fileKey

Set Upload = New FreeASPUpload

' If something fails inside the script, but the exception is handled
If Err.Number<>0 then Exit function

SaveFiles = ""
ks = Upload.UploadedFiles.keys
if (UBound(ks) <> -1) then
SaveFiles = "<B>Files uploaded:</B> "
for each fileKey in Upload.UploadedFiles.keys

'''''' GET FILENAME ''''''''

dim filenameee
filenameee = Upload.UploadedFiles(fileKey).FileName

''''''' END FILENAME '''''''

'SaveFiles = SaveFiles & Upload.UploadedFiles(fileKey).FileName & " (" & Upload.UploadedFiles(fileKey).Length & "B) "
'SaveFiles = SaveFiles & Upload.UploadedFiles(fileKey).FileName
SaveFiles = Upload.UploadedFiles(fileKey).FileName
SaveFiles = "The file name specified in the upload form does not correspond to a valid file in the system."
end if

'''''''''''''''''''''''''''''''INSERT STATEMENT''''''''''''''''''''''''''''''''''''''''''''''''''''''

dim ssql
dim connection
dim sconnstring

'To get information from any other textfields use this code.

dim varDupdate
dim varCsono_trim
dim varDoctype
dim varDocnotes

varDupdate = upload.form("dupdate")
varCsono_trim = upload.form("csono_trim")
varDoctype = upload.form("doctype")
varDocnotes = upload.form("docnotes")

sSQL="INSERT INTO [sodocs] (csono_trim,dupdate,filename,doctype,docnotes) VALUES ('" & varCsono_trim & "','" & varDupdate & "','" & filenameee & "','" & varDoctype & "','" & varDocnotes & "')"

sConnString="PROVIDER=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=e:\inetpub\databases\am_somanager.mdb"
'"Data Source=" & Server.MapPath("accessdb.mdb")
Set connection = Server.CreateObject("ADODB.Connection")




Set Connection = Nothing

'Response.AddHeader "Refresh", "2;URL=it.asp?csono_trim=" & SOnum

end function

<TITLE>SO Document Manager</TITLE>
function onSubmitForm() {
    var formDOMObj = document.frmSend;
    if (formDOMObj.filename.value == "" )
//    && formDOMObj.attach2.value == "" && formDOMObj.attach3.value == "" && formDOMObj.attach4.value == "" )
        alert("Please press the browse button and pick a file.")
        return true;
    return false;


Dim diagnostics
if Request.ServerVariables("REQUEST_METHOD") <> "POST" then
    diagnostics = TestEnvironment()
    if diagnostics<>"" then
        response.write diagnostics
        response.write "<p>After you correct this problem, reload the page."
    end if
    response.write "<center><b>Uploaded: </b>" & SaveFiles() & "</center>"
    response.write "<br>"
end if

dim conn, rsDoclist
set conn=Server.CreateObject("ADODB.Connection")
conn.Open "e:\inetpub\databases\am_somanager.mdb"

set rsDoclist = Server.CreateObject("ADODB.recordset")
rsDoclist.Open "SELECT dupdate, filename, doctype, docnotes FROM sodocs WHERE csono_trim='" & SONum & "' ORDER BY dupdate DESC", conn

<h2 align="center">Existing document list for <% = SONum %></h2>
<table border="1" id="table2" bordercolordark="#000000" cellspacing="0" align=center>
            <td bgcolor="#E5E5E5"><b>Date Added</b></td>
            <td bgcolor="#E5E5E5"><b>File</b></td>
            <td bgcolor="#E5E5E5"><b>Type</b></td>
            <td bgcolor="#E5E5E5"><b>Notes</b></td>
<%do until rsDoclist.EOF%>
            <td><% = rsDoclist.Fields("dupdate").Value %></td>
            <td><a href="../../SODocs/<% = SONum %>/<% = rsDoclist.Fields("filename").Value %>"><% = rsDoclist.Fields("filename").Value %></a></td>
            <td><% = rsDoclist.Fields("doctype").Value %></td>
            <td><% = rsDoclist.Fields("docnotes").Value %></td>
************* END UPLOADTESTER3.ASP *******************

freeASPUpload.asp - unmodified from the original
************* START FREEASPUPLOAD.ASP *******************
'  For examples, documentation, and your own free copy, go to:
'  Note: You can copy and use this script for free and you can make changes
'  to the code, but you cannot remove the above comment.

'Aug 2, 2005: Add support for checkboxes and other input elements with multiple values

Class FreeASPUpload
      Public UploadedFiles
      Public FormElements

      Private VarArrayBinRequest
      Private StreamRequest
      Private uploadedYet

      Private Sub Class_Initialize()
            Set UploadedFiles = Server.CreateObject("Scripting.Dictionary")
            Set FormElements = Server.CreateObject("Scripting.Dictionary")
            Set StreamRequest = Server.CreateObject("ADODB.Stream")
            StreamRequest.Type = 1 'adTypeBinary
            uploadedYet = false
      End Sub
      Private Sub Class_Terminate()
            If IsObject(UploadedFiles) Then
                  Set UploadedFiles = Nothing
            End If
            If IsObject(FormElements) Then
                  Set FormElements = Nothing
            End If
            Set StreamRequest = Nothing
      End Sub

      Public Property Get Form(sIndex)
            Form = ""
            If FormElements.Exists(LCase(sIndex)) Then Form = FormElements.Item(LCase(sIndex))
      End Property

      Public Property Get Files()
            Files = UploadedFiles.Items
      End Property

      'Calls Upload to extract the data from the binary request and then saves the uploaded files
      Public Sub Save(path)
            Dim streamFile, fileItem

            if Right(path, 1) <> "\" then path = path & "\"

            if not uploadedYet then Upload

            For Each fileItem In UploadedFiles.Items
                  Set streamFile = Server.CreateObject("ADODB.Stream")
                  streamFile.Type = 1
                  StreamRequest.CopyTo streamFile, fileItem.Length
                  streamFile.SaveToFile path & fileItem.FileName, 2
                  Set streamFile = Nothing
                  fileItem.Path = path & fileItem.FileName
      End Sub

      Public Function SaveBinRequest(path) ' For debugging purposes
            StreamRequest.SaveToFile path & "\debugStream.bin", 2
      End Function

      Public Sub DumpData() 'only works if files are plain text
            Dim i, aKeys, f
            response.write "Form Items:<br>"
            aKeys = FormElements.Keys
            For i = 0 To FormElements.Count -1 ' Iterate the array
                  response.write aKeys(i) & " = " & FormElements.Item(aKeys(i)) & "<BR>"
            response.write "Uploaded Files:<br>"
            For Each f In UploadedFiles.Items
                  response.write "Name: " & f.FileName & "<br>"
                  response.write "Type: " & f.ContentType & "<br>"
                  response.write "Start: " & f.Start & "<br>"
                  response.write "Size: " & f.Length & "<br>"
         End Sub

      Private Sub Upload()
            Dim nCurPos, nDataBoundPos, nLastSepPos
            Dim nPosFile, nPosBound
            Dim sFieldName, osPathSep, auxStr

            'RFC1867 Tokens
            Dim vDataSep
            Dim tNewLine, tDoubleQuotes, tTerm, tFilename, tName, tContentDisp, tContentType
            tNewLine = Byte2String(Chr(13))
            tDoubleQuotes = Byte2String(Chr(34))
            tTerm = Byte2String("--")
            tFilename = Byte2String("filename=""")
            tName = Byte2String("name=""")
            tContentDisp = Byte2String("Content-Disposition")
            tContentType = Byte2String("Content-Type:")

            uploadedYet = true

            on error resume next
            VarArrayBinRequest = Request.BinaryRead(Request.TotalBytes)
            if Err.Number <> 0 then
                  response.write "<br><br><B>System reported this error:</B><p>"
                  response.write Err.Description & "<p>"
                  response.write "The most likely cause for this error is the incorrect setup of AspMaxRequestEntityAllowed in IIS MetaBase. Please see instructions in the <A HREF=''>requirements page of</A>.<p>"
                  Exit Sub
            end if
            on error goto 0 'reset error handling

            nCurPos = FindToken(tNewLine,1) 'Note: nCurPos is 1-based (and so is InstrB, MidB, etc)

            If nCurPos <= 1  Then Exit Sub
            'vDataSep is a separator like -----------------------------21763138716045
            vDataSep = MidB(VarArrayBinRequest, 1, nCurPos-1)

            'Start of current separator
            nDataBoundPos = 1

            'Beginning of last line
            nLastSepPos = FindToken(vDataSep & tTerm, 1)

            Do Until nDataBoundPos = nLastSepPos
                  nCurPos = SkipToken(tContentDisp, nDataBoundPos)
                  nCurPos = SkipToken(tName, nCurPos)
                  sFieldName = ExtractField(tDoubleQuotes, nCurPos)

                  nPosFile = FindToken(tFilename, nCurPos)
                  nPosBound = FindToken(vDataSep, nCurPos)
                  If nPosFile <> 0 And  nPosFile < nPosBound Then
                        Dim oUploadFile
                        Set oUploadFile = New UploadedFile
                        nCurPos = SkipToken(tFilename, nCurPos)
                        auxStr = ExtractField(tDoubleQuotes, nCurPos)
                ' We are interested only in the name of the file, not the whole path
                ' Path separator is \ in windows, / in UNIX
                ' While IE seems to put the whole pathname in the stream, Mozilla seem to
                ' only put the actual file name, so UNIX paths may be rare. But not impossible.
                osPathSep = "\"
                if InStr(auxStr, osPathSep) = 0 then osPathSep = "/"
                        oUploadFile.FileName = Right(auxStr, Len(auxStr)-InStrRev(auxStr, osPathSep))

                        if (Len(oUploadFile.FileName) > 0) then 'File field not left empty
                              nCurPos = SkipToken(tContentType, nCurPos)
                    auxStr = ExtractField(tNewLine, nCurPos)
                    ' NN on UNIX puts things like this in the streaa:
                    '    ?? python py type=?? python application/x-python
                              oUploadFile.ContentType = Right(auxStr, Len(auxStr)-InStrRev(auxStr, " "))
                              nCurPos = FindToken(tNewLine, nCurPos) + 4 'skip empty line
                              oUploadFile.Start = nCurPos-1
                              oUploadFile.Length = FindToken(vDataSep, nCurPos) - 2 - nCurPos
                              If oUploadFile.Length > 0 Then UploadedFiles.Add LCase(sFieldName), oUploadFile
                        End If
                        Dim nEndOfData
                        nCurPos = FindToken(tNewLine, nCurPos) + 4 'skip empty line
                        nEndOfData = FindToken(vDataSep, nCurPos) - 2
                        If Not FormElements.Exists(LCase(sFieldName)) Then
                              FormElements.Add LCase(sFieldName), String2Byte(MidB(VarArrayBinRequest, nCurPos, nEndOfData-nCurPos))
                    FormElements.Item(LCase(sFieldName))= FormElements.Item(LCase(sFieldName)) & ", " & String2Byte(MidB(VarArrayBinRequest, nCurPos, nEndOfData-nCurPos))
                end if

                  End If

                  'Advance to next separator
                  nDataBoundPos = FindToken(vDataSep, nCurPos)
      End Sub

      Private Function SkipToken(sToken, nStart)
            SkipToken = InstrB(nStart, VarArrayBinRequest, sToken)
            If SkipToken = 0 then
                  Response.write "Error in parsing uploaded binary request."
            end if
            SkipToken = SkipToken + LenB(sToken)
      End Function

      Private Function FindToken(sToken, nStart)
            FindToken = InstrB(nStart, VarArrayBinRequest, sToken)
      End Function

      Private Function ExtractField(sToken, nStart)
            Dim nEnd
            nEnd = InstrB(nStart, VarArrayBinRequest, sToken)
            If nEnd = 0 then
                  Response.write "Error in parsing uploaded binary request."
            end if
            ExtractField = String2Byte(MidB(VarArrayBinRequest, nStart, nEnd-nStart))
      End Function

      'String to byte string conversion
      Private Function Byte2String(sString)
            Dim i
            For i = 1 to Len(sString)
               Byte2String = Byte2String & ChrB(AscB(Mid(sString,i,1)))
      End Function

      'Byte string to string conversion
      Private Function String2Byte(bsString)
            Dim i
            String2Byte =""
            For i = 1 to LenB(bsString)
               String2Byte = String2Byte & Chr(AscB(MidB(bsString,i,1)))
      End Function
End Class

Class UploadedFile
      Public ContentType
      Public Start
      Public Length
      Public Path
      Private nameOfFile

    ' Need to remove characters that are valid in UNIX, but not in Windows
    Public Property Let FileName(fN)
        nameOfFile = fN
        nameOfFile = SubstNoReg(nameOfFile, "\", "_")
        nameOfFile = SubstNoReg(nameOfFile, "/", "_")
        nameOfFile = SubstNoReg(nameOfFile, ":", "_")
        nameOfFile = SubstNoReg(nameOfFile, "*", "_")
        nameOfFile = SubstNoReg(nameOfFile, "?", "_")
        nameOfFile = SubstNoReg(nameOfFile, """", "_")
        nameOfFile = SubstNoReg(nameOfFile, "<", "_")
        nameOfFile = SubstNoReg(nameOfFile, ">", "_")
        nameOfFile = SubstNoReg(nameOfFile, "|", "_")
    End Property

    Public Property Get FileName()
        FileName = nameOfFile
    End Property

    'Public Property Get FileN()ame
End Class

' Does not depend on RegEx, which is not available on older VBScript
' Is not recursive, which means it will not run out of stack space
Function SubstNoReg(initialStr, oldStr, newStr)
    Dim currentPos, oldStrPos, skip
    If IsNull(initialStr) Or Len(initialStr) = 0 Then
        SubstNoReg = ""
    ElseIf IsNull(oldStr) Or Len(oldStr) = 0 Then
        SubstNoReg = initialStr
        If IsNull(newStr) Then newStr = ""
        currentPos = 1
        oldStrPos = 0
        SubstNoReg = ""
        skip = Len(oldStr)
        Do While currentPos <= Len(initialStr)
            oldStrPos = InStr(currentPos, initialStr, oldStr)
            If oldStrPos = 0 Then
                SubstNoReg = SubstNoReg & Mid(initialStr, currentPos, Len(initialStr) - currentPos + 1)
                currentPos = Len(initialStr) + 1
                SubstNoReg = SubstNoReg & Mid(initialStr, currentPos, oldStrPos - currentPos) & newStr
                currentPos = oldStrPos + skip
            End If
    End If
End Function
************* END FREEASPUPLOAD.ASP *******************

Sorry for the long post, but I thought it would be better than linking to the files.
Join the community to see this answer!
Join our exclusive community to see this answer & millions of others.
Unlock 2 Answers and 19 Comments.
Join the Community
Learn from the best

Network and collaborate with thousands of CTOs, CISOs, and IT Pros rooting for you and your success.

Andrew Hancock - VMware vExpert
See if this solution works for you by signing up for a 7 day free trial.
Unlock 2 Answers and 19 Comments.
Try for 7 days

”The time we save is the biggest benefit of E-E to our team. What could take multiple guys 2 hours or more each to find is accessed in around 15 minutes on Experts Exchange.

-Mike Kapnisakis, Warner Bros