Error says "failed', but it actually succeeds

**chrisj** · 03-06-2008, 01:32 PM

I'm using freeASPupload script and after I upload, I get this error:

ADODB.Stream error '800a0bbc'
Write to file failed.
/aspUpload.asp, line 135

Line 135 is: streamFile.SaveToFile path & (Session("PMMS_EMAIL")) & "~~" & fileItem.FileName, 2

And amazingly the file actually is uploaded to the correct folder destination, so I'm not sure why I'm getting this error. Can you help me get rid of the error or remedy it?

Here is the code (I've highlighted line 135 in bold):
Thanks for any assistance.

Code:

<%
'  For examples, documentation, and your own free copy, go to:
'  http://www.freeaspupload.net
'  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.
'Changes:
'Aug 2, 2005: Add support for checkboxes and other input elements with multiple values
' November 2007 added file size limitations and file extension checking
Class FreeASPUpload
 Public UploadedFiles
 Public FormElements
 Private VarArrayBinRequest
 Private StreamRequest
 Private uploadedYet
' added by Chris Hirst www.candsdesign.co.uk November 2007
 private m_lMaxFileSize
 private m_sByteMultiplier
 private m_sFileError
 private m_bFileError
' **********************************************
 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
  StreamRequest.Open
  uploadedYet = false
'  m_lMaxFileSize = 10000
 End Sub
 Private Sub Class_Terminate()
  If IsObject(UploadedFiles) Then
   UploadedFiles.RemoveAll()
   Set UploadedFiles = Nothing
  End If
  If IsObject(FormElements) Then
   FormElements.RemoveAll()
   Set FormElements = Nothing
  End If
  StreamRequest.Close
  Set StreamRequest = Nothing
 End Sub
' ***************** new properties and methods
' added by Chris Hirst www.candsdesign.co.uk  November 2007
 public function  setMaxFileSize(ByVal Val, Mult)
  m_sByteMultiplier = Mult
  select case lcase(m_sByteMultiplier)
   case ""
    m_lMaxFileSize = Val
   case "k"
    m_lMaxFileSize = Val * 1024
   case "m"
    m_lMaxFileSize = Val * (1024 * 1024)
  end select
 end function
 public property get MaxFileSize()
  MaxFileSize = m_lMaxFileSize
 end property
 public property get Error()
  Error = m_bFileError
 end property
 public property get ErrorStatus()
  ErrorStatus = m_sFileError
 end property
 private function CheckExtension(strIn)
 ' function to validate numeric input
  dim objRE
  set objRE = New RegExp
  objRE.Pattern = "^.+\.((txt)|(pdf)|(html)|(htm)|(doc)|(rtf))$"
  objRE.Global = True
  CheckExtension = objRE.test(strIn)
  set objRE = nothing
 end function
 public function getMult()
  select case lcase(m_sByteMultiplier)
   case ""
    getMult = "Bytes"
   case "k"
    getMult = "Kilobytes"
   case "m"
    getMult = "Megabytes"
  end select
 end function
' *************** end new property
 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
 ' Save method recoded November 2007 to add checks for files size and extensions
 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
  m_bFileError = false
  if fileItem.Length > m_lMaxFileSize then
   m_sFileError = "Exceeds maximum filesize"
   m_bFileError = true
  end if
  if not CheckExtension(fileItem.FileName)  then
   m_sFileError = "Invalid filetype"
   m_bFileError = true
  end if
  if not m_bFileError then
   Set streamFile = Server.CreateObject("ADODB.Stream")
   streamFile.Type = 1
   streamFile.Open
   StreamRequest.Position=fileItem.Start
   StreamRequest.CopyTo streamFile, fileItem.Length
   streamFile.SaveToFile path & (Session("PMMS_EMAIL")) & "~~" & fileItem.FileName, 2
   streamFile.close
   Set streamFile = Nothing
   fileItem.Path = path & fileItem.FileName
  else
   fileItem.FileName = fileItem.FileName & " Discarded - " & m_sFileError
  end if
   Next
 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>"
  Next
  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>"
   Next
    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='http://www.freeaspupload.net/freeaspupload/requirements.asp'>requirements page of freeaspupload.net</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
   Else
    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))
    else
                    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)
  Loop
  StreamRequest.Write(VarArrayBinRequest)
 End Sub
 Private Function SkipToken(sToken, nStart)
  SkipToken = InstrB(nStart, VarArrayBinRequest, sToken)
  If SkipToken = 0 then
   Response.write "Error in parsing uploaded binary request."
   Response.End
  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."
   Response.End
  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)))
  Next
 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)))
  Next
 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
    Else
        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
            Else
                SubstNoReg = SubstNoReg & Mid(initialStr, currentPos, oldStrPos - currentPos) & newStr
                currentPos = oldStrPos + skip
            End If
        Loop
    End If
End Function
%>

**kline11** · 03-19-2008, 09:31 AM

Ask Chris Hirst,
He wrote most of it.