UNKNOWN '************************************** ' Name: Form Based File Upload Using Pur ' e ASP ' Description:This code will allow you t ' o do form based file uploads. It support ' s multiple files and uses only pure ASP. ' There are no components to install so it ' will work on any web server that support ' s ASP. Just paste this code into a text ' file and name it saveany.asp. I have tes ' ted it on IIS 4 and 5, with IE 4, IE 5 a ' nd Netscape 6. With this code you will b ' e able to save a file in any directory t ' hat the anonymous account assigned to it ' (usually IUSER_machinename) has access t ' o so be careful. I should note that the ' server needs ADO and the File System Obj ' ect installed on it, but both of these a ' re installed by default with ASP. Added ability to parse form data. Added ability to browse server folders for save location. ' By: Karl P. Grear ' ' ' Inputs:None ' ' Returns:None ' 'Assumes:None ' 'Side Effects:None 'This code is copyrighted and has limite ' d warranties. 'Please see http://www.Planet-Source-Cod ' e.com/xq/ASP/txtCodeId.6569/lngWId.4/qx/ ' vb/scripts/ShowCode.htm 'for details. '************************************** <%response.buffer=true Func = Request("Func") if isempty(Func) Then Func = 1 End if Select Case Func Case 1 'You do not need to use this form to 'send your files. BrowseServer = Request.Form("BrowseServer") %> <h2>File Upload Form.</h2> <table> <form enctype="multipart/form-data" action="/" method="POST" id="form1" name="form1"> <tr><td><strong>Debug Options.</strong><br></td></tr> <tr><td><input name="Options" type="CheckBox" value="Raw">Create Raw File<br></td></tr> <tr><td><input name="Options" type="CheckBox" value="Boundry">Create Boundry File<br><br></td></tr> <tr><td><strong>Hit the [Browse Server] button to find the folder on the server to upload to.</strong><br></td></tr> <tr><td><input name="ServerPath" size="30" type="Text" value="<%= BrowseServer %>"><input type="button" value="Browse Server" onclick="document.location='saveany.asp?func=3'" id="button1" name="button1"><br><br></td></tr> <tr><td><strong>Hit the [Browse] button to find the file on your computer.</strong><br></td></tr> <tr><td><input name="File1" size="30" type="file"><br></td></tr> <tr><td><input name="File2" size="30" type="file"><br></td></tr> <tr><td><input name="File3" size="30" type="file"><br><br></td></tr> <tr><td><strong>Enter security password.</strong><br></td></tr> <tr><td><input name="Password" size="30" type="Text"><br></td></tr> <tr><td align="left"><input name="submit" type="submit" value="Upload File"><br><br></td></tr> <tr><td>NOTE: Please be patient, you will not receive any notification until the file is completely transferred.<br><br></td></tr> </form> </table> <% Case 2 Server.ScriptTimeout=300 ForWriting = 2 adLongVarChar = 201 lngNumberUploaded = 0 'Get binary data from form noBytes = Request.TotalBytes binData = Request.BinaryRead (noBytes) 'convery the binary data to a string Set RST = CreateObject("ADODB.Recordset") LenBinary = LenB(binData) if LenBinary > 0 Then RST.Fields.Append "myBinary", adLongVarChar, LenBinary RST.Open RST.AddNew RST("myBinary").AppendChunk BinData RST.Update strDataWhole = RST("myBinary") End if 'get the boundry indicator strBoundry = Request.ServerVariables ("HTTP_CONTENT_TYPE") lngBoundryPos = instr(1,strBoundry,"boundary=") + 8 strBoundry = "--" & right(strBoundry,len(strBoundry)-lngBoundryPos) 'ParseForm returns a dictionary object 'You can ParseForm any time after the 'Boundry indicator is set. set dPassword = ParseForm("Password") set dOptions = ParseForm("Options") 'both of these are valid Response.Write ParseForm("Password").item(0) & "<br>" Response.write dPassword.item(0) & "<br>" SavePath = ParseForm("ServerPath").item(0) if SavePath = "" or isempty(SavePath) then Response.Write "<h2> The following Error occured.</h2>" Response.Write "You did not enter a server path to save your file to." Response.Write "<br><br>Hit the back button, make the needed corrections and resubmit your information." Response.Write "<br><br><input type="button" onclick="history.go(-1)" value="<< Back" id="button" 1 name="button" 1>" Response.End end if intCount = dOptions.count if intCount > 0 then for x = 0 to intCount Select case dOptions.item(x) case "Raw" Raw = True case "Boundry" Boundry = True end select next else Raw = false Boundry = false end if if dPassword.item(0) <> "oktosend" then Response.Write "<h2> The following Error occured.</h2>" Response.Write "The Password you entered is invalid." Response.Write "<br><br>Hit the back button, make the needed corrections and resubmit your information." Response.Write "<br><br><input type="button" onclick="history.go(-1)" value="<< Back" id="button" 1 name="button" 1>" Response.End end if 'Creates a raw data file for with all 'data sent. Uncomment for debuging. if Raw then Set fso = CreateObject("Scripting.FileSystemObject") Set f = fso.OpenTextFile(SavePath & "\raw.txt", ForWriting, True) f.Write strDataWhole set f = nothing set fso = nothing end if 'Get first file boundry positions. lngCurrentBegin = instr(1,strDataWhole,strBoundry) lngCurrentEnd = instr(lngCurrentBegin + 1,strDataWhole,strBoundry) - 1 countloop = 0 Do While lngCurrentEnd > 0 'Get the data between current boundry 'and remove it from the whole. strData = mid(strDataWhole,lngCurrentBegin, (lngCurrentEnd - lngCurrentBegin) + 1) 'Remove the file data from the whole 'strDataWhole = replace(strDataWhole,strData,"") 'Get the full path of the current file. lngBeginFileName = instr(1,strdata,"filename=") + 10 lngEndFileName = instr(lngBeginFileName,strData,chr(34)) 'Make sure they selected at least one 'file. if lngBeginFileName = lngEndFileName and lngNumberUploaded = 0 Then Response.Write "<h2> The following Error occured.</h2>" Response.Write "You must Select at least one file To upload" Response.Write "<br><br>Hit the back button, make the needed corrections and resubmit your information." response.Write "<br><br><input type="button" onclick="history.go(-1)" value="<< Back" id="button" 1 name="button" 1>" Response.End End if 'There could be one or more empty file b ' 'oxes. if lngBeginFileName <> lngEndFileName and lngBeginFileName - 10 <> 0 Then strFilename = mid(strData,lngBeginFileName,lngEndFileName - lngBeginFileName) 'Creates a raw data file with data 'between current boundrys. Uncomment 'for debuging. if Boundry then Set fso = CreateObject("Scripting.FileSystemObject") Set f = fso.OpenTextFile(SavePath & "\raw_" & lngNumberUploaded & ".txt", ForWriting, True) f.Write strData set f = nothing set fso = nothing end if 'Loose the path information and keep 'just the file name. tmpLng = instr(1,strFilename,"\") Do While tmpLng > 0 PrevPos = tmpLng tmpLng = instr(PrevPos + 1,strFilename,"\") Loop FileName = right(strFilename,len(strFileName) - PrevPos) 'Get the begining position of the file 'data sent. 'if the file type is registered with 'the browser then there will be a 'Content-Type lngCT = instr(1,strData,"Content-Type:") if lngCT > 0 Then lngBeginPos = instr(lngCT,strData,chr(13) & chr(10)) + 4 Else lngBeginPos = lngEndFileName End if 'Get the ending position of the file 'data sent. lngEndPos = len(strData) 'Calculate the file size. lngDataLenth = (lngEndPos - lngBeginPos) -1 'Get the file data strFileData = mid(strData,lngBeginPos,lngDataLenth) 'Create the file. Set fso = CreateObject("Scripting.FileSystemObject") Set f = fso.OpenTextFile(SavePath & "\" & FileName, ForWriting, True) f.Write strFileData Set f = nothing Set fso = nothing if lngNumberUploaded = 0 then Response.Write "<strong>Saving Files...</strong><br><br>" end if Response.Write SavePath & "\" & FileName & "<br>" lngNumberUploaded = lngNumberUploaded + 1 End if 'Get then next boundry postitions if 'any. lngCurrentBegin = lngCurrentEnd lngCurrentEnd = instr(lngCurrentBegin + 9 ,strDataWhole,strBoundry) - 1 'Prevents infinate loop. countloop = countloop + 1 if countloop = 100 then Response.Write "looped 100 times terminating script!" Response.End end if loop Response.Write "<strong>" & lngNumberUploaded & " File(s) Uploaded</strong>" Response.Write "<br><br><input type="button" onclick="document.location=" & chr(34) & "saveany.asp" & chr(34) & "" value="<< Back to Listings" id="button" 1 name="button" 1>" Case 3 'get prev path if any path = Request.QueryString("Path") 'if not assign one if path = "" or isempty(path) then path = "c:\inetpub" end if 'create filesystemobject Set fso = CreateObject("Scripting.FileSystemObject") 'get a folder object set f = fso.GetFolder(path) path = f.path 'limit access to hard drive if lcase(left(path,10)) <> "c:\inetpub" then path = "C:\Inetpub" set f = fso.GetFolder(path) path = f.path end if Response.Write "<h2>Server Browse Form.</h2>" Response.Write "<form action="/" method="POST">" Response.Write "<table width="400" border="1" cellpadding="0" cellspacing="1">" & vbcrlf Response.Write "<tr><th colspan="2">" & path & "</th></tr>" Response.Write "<tr><td colspan="2" align="left"><a href="/"><strong>Parent ..</strong></a></td></tr>" & vbcrlf 'get subfolders collection set fc = f.subfolders 'enum subfolders for each folder in fc Response.Write "<tr><td align="left"><input name="BrowseServer" type="CheckBox" value="" & folder.path & ""></td><td style="padding-left: 20px;" align="left"><a href="/">" & folder.name & "</a></td></tr>" & vbcrlf next 'if there is a folder display the select folder button if fc.count > 0 then Response.Write "<tr><td align="left" colspan="2"><br><input name="submit" type="submit" value="Select Folder"></td></tr>" end if Response.Write"<tr><td colspan="2"><input name="cancel" type="Button" value="Cancel" onclick="document.location='saveany.asp?func=1'"></td></tr>" Response.Write "</table>" & vbcrlf Response.Write "</form>" end select %> </body> </html> <script language="vbscript" runat="Server"> Function ParseForm(strFieldName) Set strFormData = CreateObject("Scripting.Dictionary") lngCount = -1 'Try to find the Field lngNamePos = instr(1,strDataWhole,"name=" & chr(34) & strFieldName & chr(34)) 'Parse through data in search of fields do while lngNamePos <> 0 lngCount = lngCount + 1 lngBeginFieldData = instr(lngNamePos,strDataWhole,vbcrlf & vbcrlf)+4 lngEndFieldData = instr(lngBeginFieldData,strDataWhole,vbcrlf) strFormData.Add lngCount, mid(strDataWhole,lngBeginFieldData,lngEndFieldData-lngBeginFieldData) lngNamePos = instr(lngEndFieldData,strDataWhole,"name=" & chr(34) & strFieldName & chr(34)) loop set ParseForm = strFormData end function </script>