A Free File Uploader

[arijitsinha99 0]

Dear Friends

This is a free fileupload script written in ASP. I found this script a few month back on internet. So I just want to share it with u.

 

You are requested to leave the copy rights Intect

freeASPUpload.asp---FILE NAME

_________________________________________________________________________________________

 

<%

' For examples, documentation, and your own free copy, go to:

' http://forums.xisto.com/no_longer_exists/

' 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

 

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

StreamRequest.Open

uploadedYet = false

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

 

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

streamFile.Open

StreamRequest.Position=fileItem.Start

StreamRequest.CopyTo streamFile, fileItem.Length

streamFile.SaveToFile path & fileItem.FileName, 2

streamFile.close

Set streamFile = Nothing

fileItem.Path = path & fileItem.FileName

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("(anti-spam-(anti-spam-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://forums.xisto.com/no_longer_exists/&%2339 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 vb script: http://www.webfilebrowser.com/

 

function OutputForm()

%>

<form name="frmSend" method="POST" enctype="multipart/form-data" action="uploadTester.asp" onSubmit="return onSubmitForm();">

<B>File names:</B><br>

File 1: <input name="attach1" type="file" size=35><br>

File 2: <input name="attach2" type="file" size=35><br>

File 3: <input name="attach3" type="file" size=35><br>

File 4: <input name="attach4" type="file" size=35><br>

<br>

 

<input style="margin-top:4" type=submit value="Upload">

</form>

<%

end function

 

function TestEnvironment()

Dim fso, fileName, testFile, streamTest

TestEnvironment = ""

Set fso = Server.CreateObject("Scripting.FileSystemObject")

if not fso.FolderExists(uploadsDirVar) then

TestEnvironment = "<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."

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

Err.Clear

testFile.Close

fso.DeleteFile(fileName)

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

Err.Clear

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

Upload.Save(uploadsDirVar)

 

' 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

SaveFiles = SaveFiles & Upload.UploadedFiles(fileKey).FileName & " (" & Upload.UploadedFiles(fileKey).Length & " "

next

else

SaveFiles = "The file name specified in the upload form does not correspond to a valid file in the system."

end if

 

end function

%>

 

<HTML>

<HEAD>

<TITLE>Upload</TITLE>

<style>

BODY {background-color: white;font-family:arial; font-size:12}

</style>

<script>

function onSubmitForm() {

var formDOMObj = document.frmSend;

if (formDOMObj.attach1.value == "" && formDOMObj.attach2.value == "" && formDOMObj.attach3.value == "" && formDOMObj.attach4.value == "" )

alert("Please press the browse button and pick a file.")

else

return true;

return false;

}

</script>

 

</HEAD>

 

<BODY>

 

<br><br>

<div style="border-bottom: #A91905 2px solid;font-size:36" align=center>Upload files to our server</div>

<%

Dim diagnostics

if Request.ServerVariables("REQUEST_METHOD") <> "POST" then

diagnostics = TestEnvironment()

if diagnostics<>"" then

response.write "<div style=""margin-left:20; margin-top:30; margin-right:30; margin-bottom:30;"">"

response.write diagnostics

response.write "<p>After you correct this problem, reload the page."

response.write "</div>"

else

response.write "<div style=""margin-left:150"">"

OutputForm()

response.write "</div>"

end if

else

response.write "<div style=""margin-left:150"">"

OutputForm()

response.write SaveFiles()

response.write "<br><br></div>"

end if

 

%>

 

 

<div style="border-bottom: #A91905 2px solid;font-size:10"></div>

 

<br><br>

 

 

</BODY>

</HTML>

______________________________________________________________________________________

 

 

 

Using this files u can upload files....happpy uploading.

 

NOTE :- If u need help...go to http://forums.xisto.com/no_longer_exists/

It is creators site......

 

Notice from saint-michael:

If you are going ot copy scripts from another website they must be put in quotes since its not your original work. Credits reduce.

[farsiscript 0]

i dont have information about ASP plz Write how to use this code

[ddanime 0]

He posted the creators site http://forums.xisto.com/no_longer_exists/ you should find help there. thanks I've been looking for a file upload program maybe I'll give this a try when I have more time.

[Plenoptic 0]

ASP is sort of like PHP. PHP is used on Linux servers and ASP on Windows servers. They are closely related in function but ASP sort of relates to VB coding. This host I don't think supports ASP because it is run on Linux servers and is less commonly used.

[ddanime 0]

PHP suppors windows and linux, ASP only supports windows. but linux and PHP are superior!