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 please 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. <% ' 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 [B]streamFile.SaveToFile path & (Session("PMMS_EMAIL")) & "~~" & fileItem.FileName, 2[/B] 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 %> Code (markup):
Hello Chrisj, Thats quite a bit of code! One question, are you using a shared host or do you fully own the server?