\'**************************************
\' 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=\"saveany.asp?func=2\" 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=\'saveany.asp?func=1\' 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=\'saveany.asp?func=3&path=\" & path & \"\\..\'><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=\'saveany.asp?func=3&path=\" & folder.path & \"\'>\" & 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>
Ny bruger
Nybegynder
Opret
Preview
