Sistema De Upload!

gente vou colocar o codigo pra ver se facilita...

codigo do upload....

<%
'  For examples, documentation, and your own free copy, go to:
'  http://www.freeaspupload.net
'  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.

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 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

  '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

  VarArrayBinRequest = Request.BinaryRead(Request.TotalBytes)

  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, sFileName
    Set oUploadFile = New UploadedFile
    
    nCurPos = SkipToken(tFilename, nCurPos)
    sFileName = ExtractField(tDoubleQuotes, nCurPos)
    oUploadFile.FileName = Right(sFileName, Len(sFileName)-InStrRev(sFileName, "\"))

    if (Len(oUploadFile.FileName) > 0) then 'File field not left empy
   	 nCurPos = SkipToken(tContentType, nCurPos)
   	 
   	 oUploadFile.ContentType = ExtractField(tNewLine, nCurPos)
   	 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))
 	 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

	Public Function SaveBinRequest(path) ' For debugging purposes
  StreamRequest.SaveToFile path & "debugStream.bin", 2
	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 FileName
	Public Start
	Public Length
	Public Path
End Class
%>

E segue abaixo o codigo do form chamando funcoes do codigo acima...

------------------------------------------------------------------------------------------------

<%@ Language=VBScript %>
<% 
option explicit 
Response.Expires = -1
Server.ScriptTimeout = 60
%>
<!-- #include file="freeaspupload.asp" -->
<%


' ****************************************************
' Change the value of the variable below to the pathname
' of a directory with write permissions, for example "C:\Inetpub\wwwroot"
  Dim uploadsDirVar
  uploadsDirVar = server.MapPath("..\fotos") 
' ****************************************************

' Note: this file uploadTester.asp is just an example to demonstrate
' the capabilities of the freeASPUpload.asp class. There are no plans
' to add any new features to uploadTester.asp itself. Feel free to add
' your own code. If you are building a content management system, you
' may also want to consider this script: http://www.webfilebrowser.com/

function OutputForm()
%>
    <form name="frmSend" method="POST" enctype="multipart/form-data" action="uploadTester.asp" onSubmit="return onSubmitForm();">
    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)

    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 & "B) "
         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>Test Free ASP 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:16">Upload files to your 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-top: #A91905 2px solid;font-size:10">Powered by <A HREF="http://www.freeaspupload.net/" style="color:black">Free ASP Upload</A></div>

</BODY>
</HTML>

Gente procurem observar a parte do codigo acima na funcao OutPutForm() onde é nela q estão os forms mas somente os tipo file...
coomo faria para colocar tb os outros tipos?
Preciso mt da ajuda de vcs...
Obrigado!

#1 betonit

#2 betonit

#3 wozniak

#4 <%Rafael%>

#5 K I L L I N G

#6 <%Rafael%>

#7 lazerediversao

#8 <%Rafael%>

1 user(s) are reading this topic