<%
' upload.asp
' Updated : 2549-06-23 Created : 2549-02-23
' มาจาก http://www.freeaspupload.net/freeaspupload/freeASPUpload.zip"
' หลังปรับปรุง : http://www.thaiall.com/source/
' ****************************************************
' สิ่งที่ปรับปรุง
' - ใช้งานได้ทันที โดยไม่ต้อง config ใด ๆ อีก
' - ใช้เพียง upload.asp ก็ทำงานได้
' - นำ html ด้านล่างไปใช้ เพื่อส่งแฟ้มจากเว็บเพจอื่น
' - กำหนด folder ได้ผ่านตัวแปร destination_folder
' ****************************************************
' สำหรับเรียนใช้ upload.asp จากที่อื่น
' <form method="post" enctype="multipart/form-data" action="upload.asp">
' <input name="redirect" value=http://www.thaiall.com/source size=30><br>
' <input name="attach1" type="file"><br>
' <input type=submit value="ส่ง">
' </form>
' ****************************************************
option explicit
Response.Expires = -1
Server.ScriptTimeout = 600
public destination_folder
public redirect_url
' ****************************************************
' Configuration
destination_folder = "" ' เช่น "\upload"
dim subfolder
subfolder = split(replace(request.servervariables("HTTP_REFERER"),"%5C","\"),"=")
if (ubound(subfolder) > 0) then destination_folder = subfolder(1)
' ****************************************************
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("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
' ****************************************************
function OutputForm() %>
<html><head><title>Upload</title><meta http-equiv=content-type content="text/html; charset=windows-874"></head>
<body bgcolor=#ffffdd>
<table align=center><td vlaign=top>
<form name="frmSend" method="POST" enctype="multipart/form-data" action="<%=scriptname %>" onSubmit="return onSubmitForm();">
<b>แบบที่ 1</b> : ส่งหลายแฟ้ม<br>
<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 type=submit value="Upload">
</form><hr>
<form name="dir" method="GET" action="<%=scriptname %>">
Folder : <input name=subfolder value="<% response.write(destination_folder) %>">
<br>? ถ้าไม่ระบุจะเป็น Current
<br>? ถ้าระบุให้ใช้เครื่องหมาย \ นำหน้าชื่อ เช่น \xxx
<br>? ทุกครั้งที่กำหนด Folder ต้องกดปุ่ม SELECT ก่อนเลือกแฟ้ม เสมอ
<br><input type=submit value="SELECT">
</form>
<form name="dir" method="get" action="<%=scriptname %>">
<input type=submit value="Back">
</form>
</td><td bgcolor=#dddddd> </td><form method="POST" enctype="multipart/form-data" action="upload.asp"><td valign=top>
<b>แบบที่ 2</b> : ส่งแฟ้มเดียว<br>
File : <input name="attach1" type="file"><br>
Redirect : <input name=redirect value=http://www.thaiall.com/source size=30><br>
เติม type=hidden ได้<br>
<input type=submit value="ส่ง">
</form>
</td></table>
<%
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 & " Bytes) "
next
else
SaveFiles = "The file name specified in the upload form does not correspond to a valid file in the system."
end if
redirect_url = Upload.Form("redirect")
end function
' ****************************************************
' Change the value of the variable below to the pathname
' of a directory with write permissions, for example "C:\Inetpub\wwwroot"
Dim uploadsDirVar,scriptname
dim a,n,i
a = Split(request.servervariables("PATH_TRANSLATED"),"\")
n = a(0)
for i=1 to ubound(a) - 1
n = n & "\" & a(i)
next
' uploadsDirVar = "d:\inetpub\webmailasp\database\tempUploads"
scriptname = a(ubound(a))
uploadsDirVar = n & destination_folder
' ****************************************************
Dim diagnostics
if Request.ServerVariables("REQUEST_METHOD") <> "POST" then
%>
<html><head>
<meta http-equiv=content-type content="text/html; charset=windows-874">
<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>
<%
diagnostics = TestEnvironment()
if diagnostics<>"" then
response.write diagnostics
response.write "<p>After you correct this problem, reload the page."
else
OutputForm()
end if
response.write "<hr color=blue>Script from : http://www.freeaspupload.net/freeaspupload/freeASPUpload.zip"
response.write "<br>ปรับปรุงแล้วเผยแพร่ผ่าน : http://www.thaiall.com/source/"
%>
<pre><ul><font face=fixedsys color=blue><b>Sample Code:</b>
<form method="post" enctype="multipart/form-data" action="upload.asp">
<input name="redirect" value=http://www.thaiall.com/source size=30<<br>
<input name="attach1" type="file"><br>
<input type=submit value="ส่ง">
</form>
</font></ul></pre>
</body></html>
<%
else
OutputForm() ' แสดงฟอร์มรับค่า
response.write SaveFiles()
if (len(redirect_url) > 5) then
' response.write("<meta http-equiv=refresh content='0;url="& redirect_url &"'>")
response.redirect(redirect_url)
end if
response.end
end if
%>