thaiall logomy background
coding : upload.asp.
my town
Source : Perl | PHP | ASP | JSP | HTML | HTML5 | JavaScript | Java | COBOL | C++ | MS Access | VBNet | VB | Python | โค้ดดี
File : upload.asp. ID : 9123
Skin : Default | Sons-of-obsidian | Sunburst | Highlighter | Full
<%
' 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>
&lt;form method="post" enctype="multipart/form-data" action="upload.asp"&gt;
&lt;input name="redirect" value=http://www.thaiall.com/source size=30&lt;&lt;br&gt;
&lt;input name="attach1" type="file"&gt;&lt;br&gt;
&lt;input type=submit value="ส่ง"&gt;
&lt;/form&gt; 
</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
%>
จำนวน : 403 บรรทัด
าษาเฮชทีเอ็มแอล (HTML = HyperText Markup Language) คือ ภาษาคอมพิวเตอร์ที่ออกแบบมาเพื่อใช้ในการสร้างเว็บเพจที่เรียกดูผ่านทางเว็บเบราว์เซอร์ (Web Browser) เริ่มพัฒนาโดย ทิม เบอร์เนอรส์ ลี (Tim Berners Lee) ในปัจจุบัน HTML ล่าสุดคือ รุ่น 5 เป็นมาตรฐานหนึ่งของ ISO ซึ่งจัดการโดย World Wide Web Consortium (W3C) ในปัจจุบัน ทาง W3C ผลักดัน รูปแบบของ HTML แบบใหม่ ที่เรียกว่า XHTML รุ่นแรกคือ 1.0 (ม.ค.2543) ซึ่งมีโครงสร้างเป็นแบบ XML (eXtensible Markup Language)
าษาพีเอชพี (PHP Language) คือ ภาษาคอมพิวเตอร์ประเภทโอเพนท์ซอร์ท (Open Source Computer Language) สำหรับพัฒนาเว็บเพจแบบไดนามิก เมื่อเครื่องบริการได้รับคำร้องจากผู้ใช้ก็จะส่งให้กับ ตัวแปลภาษา ทำหน้าที่ประมวลผลและส่งข้อมูลกลับไปยังเครื่องของผู้ใช้ที่ร้องขอ ในรูปเอชทีเอ็มแอล ภาพ หรือแฟ้มดิจิทอลอื่นใด ลักษณะของภาษามีรากฐานคำสั่งมาจากภาษาซี เป็นภาษาที่สามารถพัฒนาให้ใช้งานแบบโต้ตอบกับผู้ใช้ได้
าษาไพทอน (Python Language) คือ ภาษาคอมพิวเตอร์ประเภทโอเพนท์ซอร์ท (Open Source Computer Language) สำหรับพัฒนาแอพพลิเคชั่นโดยไม่ยึดติดกับแพลตฟอร์ม (Platform) และใช้ในงานได้หลายประเภท ทั้งใช้ในการประมวลผลผ่านคอมมานด์ไลน์ หรือเป็นเว็บเพจแบบไดนามิก เมื่อเครื่องบริการได้รับคำร้องจากผู้ใช้ก็จะส่งให้โค้ดให้กับตัวแปลภาษา เพื่อทำหน้าที่ประมวลผลและส่งข้อมูลกลับไปยังเครื่องของผู้ใช้ที่ร้องขอ ในรูปข้อความ เอชทีเอ็มแอล ภาพ หรือแฟ้มดิจิทอลอื่นใด ลักษณะของภาษามีรากฐานคำสั่งมาจากภาษาซี เป็นภาษาที่สามารถพัฒนาให้ใช้งานแบบโต้ตอบกับผู้ใช้ได้ จุดที่แตกต่างกับภาษาอื่น คือ การรวบรวมจุดเด่นของแต่ละภาษามารวมเข้าด้วยกัน
อสคิวแอล (SQL = Structured Query Language) คือ ภาษาสอบถามข้อมูล หรือภาษาจัดการข้อมูลอย่างมีโครงสร้าง มีการพัฒนาภาษาคอมพิวเตอร์ และโปรแกรมฐานข้อมูลที่รองรับมากมาย เพราะจัดการข้อมูลได้ง่าย เช่น MySQL, MariaDB, MsSQL, PostgreSQL หรือ MS Access เป็นต้น สำหรับโปรแกรมฐานข้อมูลที่ได้รับความนิยมคือ MySQL หรือ MariaDB เป็น Open Source ที่ใช้งานได้ทั้งใน Linux และ Windows
วัสดีชาวโลก (Hello World) คือ ผลลัพธ์ครั้งแรกที่นักพัฒนาโปรแกรมนิยมเลือกใช้แสดงผลในโปรแกรมแรกที่เขียนขึ้นเพื่อทดสอบการทำงาน ข้อความนี้ทำให้นึกถึงมนุษย์ต่างดาวที่มาเยือนโลกและกล่าวกับมนุษย์เมื่อพบกันครั้งแรกในภาพยนตร์
ตัวอย่าง Hello World
ปรับปรุงโปรแกรม source.pl : 2565-07-24
rspsocial
Thaiall.com