[Resolvido] Barra de Status/Progresso de envio de arquivo usando ASPUp

BelSelf (Silvano Soares) · Julho 31, 2008

Bom dia amigos,

Gostaria de ajuda pra desenvolver uma barra de status no script de envio de arquivos q peguei no laboratório de Scripts e funciona muito bem, o único problema é q se mando um arquivo muito grande tem-se a impressão q travou o Browser, então gostaria de por uma barra de status/progresso do envio, alguém ja fez algo parecido ou pode me ajudar??

Abaixo os scripts q estou usando:

upload.asp

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


' ****************************************************
' Pasta onde será salvo os arquivos enviados
  Dim uploadsDirVar
  uploadsDirVar = "D:\Teste\Files" 
' ****************************************************


function OutputForm()
%>
	<form name="frmSend" method="POST" enctype="multipart/form-data" action="upload.asp" onSubmit="return onSubmitForm();">
	<B>Selecione o Arquivo para Envio:</B><br>
	Arquivo: <input name="attach1" type="file" size=72><br>
	<br> 
	<input style="margin-top:4" type=submit value="Enviar">

	</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, MB

	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>Arquivo Transferido:</B> "
		for each fileKey in Upload.UploadedFiles.keys
			' & " (" & Upload.UploadedFiles(fileKey).Length & "B) "
			MB = Upload.UploadedFiles(fileKey).Length / 1024
			MB = CInt(MB)
			SaveFiles = SaveFiles & Upload.UploadedFiles(fileKey).FileName & " ( " & MB & " KB)"

		next
		'if MB > 102400 then
	   ' 	alert("Arquivo de tamanho maior que o limite de envio")
	   ' endif
	else
		SaveFiles = "O nome do arquivo especificado para transferência não corresponde a um arquivo válido."
	end if
end function
%>

<HTML>
<HEAD>
<TITLE>Envio de Arquivos</TITLE>
<style>
BODY {background-color: white;font-family:arial; font-size:12}
</style>
<script>
function onSubmitForm() {
	var formDOMObj = document.frmSend;
	if (formDOMObj.attach1.value == "")
		alert("Por favor clique no botão procurar e selecione um arquivo.")
	else
	   	return true;
	return false;
}
</script>

</HEAD>

<BODY>

<br><br>
<div style="border-bottom: #A91905 2px solid;font-size:16">Envio de arquivos - Máximo 100 Mb por arquivo </div>
<%
Dim diagnostics
Dim resultado
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>Depois de corrigir o problema, atualize a pagina."
		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()
	resultado=SaveFiles
   
	response.write "<br><br></div>"
%>	
<script>
	alert("Arquivo enviado com sucesso.")
</script>
<%
end if
%>

<br><br>

</BODY>
</HTML>[/codebox]


ASPUpload.asp
[codebox]<%
'  For examples, documentation, and your own free copy, go to:
'  [url="http://www.freeaspupload.net"]http://www.freeaspupload.net[/url]
'  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("Content-Type:")

		uploadedYet = true

		on error resume next
		VarArrayBinRequest = Request.BinaryRead(Request.TotalBytes)
		if Err.Number <> 0 then 
			response.write "<br><br><B>O Sistema reportou o seguinte erro:</B><p>"
			response.write Err.Description & "<p>"
			response.write "Favor verificar o tamanho do arquivo, limite para envio de 100 Mb"
			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
%>

Ja fiz alguns testes e não consegui colocar nem depois de clicar no botão enviar uma mensagem dizendo "Aguarde enviando arquivo.."

Aguardo ajuda de vcs,

Obrigado

jrcardozo · Julho 31, 2008

se você quer usando aspupload veja no manual do fabricante: http://support.persits.com/upload/progress.asp

com freeaspupload você terá que criar alguma dll para fazer a tarefa da barra de progresso

Ted k' · Agosto 1, 2008

ou então usar um AJAX para isso, só para contar o tempo de upload!

BelSelf (Silvano Soares) · Agosto 1, 2008

se você quer usando aspupload veja no manual do fabricante: http://support.persits.com/upload/progress.asp

com freeaspupload você terá que criar alguma dll para fazer a tarefa da barra de progresso

Obrigado pela dica jontahndj, vou dar uma olhada e ver se posso suar e adaptar.

Abraços http://forum.imasters.com.br/public/style_emoticons/default/thumbsup.gif

BelSelf (Silvano Soares) · Agosto 1, 2008

ou então usar um AJAX para isso, só para contar o tempo de upload!

Olá Ted k, aonde consigo mais informações sobre isto?

Obrigado, abraços

hargon · Agosto 1, 2008

Um exemplo...

http://neosite.ilogic.com.br/dicas/2007/08...-javascript.htm

BelSelf (Silvano Soares) · Agosto 1, 2008

Um exemplo...

http://neosite.ilogic.com.br/dicas/2007/08...-javascript.htm

Obrigado hargon, dei uma olhada no exemplo, muito legal, mas da maneira q o jonathan mostro no site q me passou é bem o q estou precisando, baixei o componente e adaptei um pouco da maneira q precisava e está funcionando muito bem o problema é que se tento enviar um arquivo grande tipo + de 10 MB ele apresenta a seguinte msg:

Active Server Pages error 'ASP 0113'

Script timed out

/progress_upload.asp

The maximum amount of time for a script to execute was exceeded. You can change this limit by specifying a new value for the property Server.ScriptTimeout or by changing the value in the IIS administration tools.

Ja configurei o IIS pra 360000 seg.

e coloquei no código

Server.ScriptTimeout = 180

na Barra de progresso chega a 100% e retorna esse erro, alguém pode me ajduar nessa agora??

Obrigado pela ajuda amigos.

Abraços

hargon · Agosto 1, 2008

Isso você tem que ver com seu servidor, qual o limite para Upload. Tem servidor que é limitado a 10 mb... você não conseguirá enviar mais que isso.

BelSelf (Silvano Soares) · Agosto 2, 2008

Isso você tem que ver com seu servidor, qual o limite para Upload. Tem servidor que é limitado a 10 mb... você não conseguirá enviar mais que isso.

Olá hargon, então o servidor é meu, eu configuro ele da maneira que preciso, alterei o Script Limited do IIS para 36000 seg. e mesmo assim retorna a mensagem, é um servidor com o Server 2003 R2, será que alguém tem uma dica?

Obrigado, ótimo final de semana a todos!!

BelSelf (Silvano Soares) · Agosto 5, 2008

Ninguém pode me ajudar neste erro??

Obrigado amigos.

Ted k' · Agosto 5, 2008

é como o hargon falou cara, tem limite, então aumenta seu Server.ScriptTimeout para:

Server.ScriptTimeOut = 999999999

BelSelf (Silvano Soares) · Agosto 11, 2008

é como o hargon falou cara, tem limite, então aumenta seu Server.ScriptTimeout para:
Server.ScriptTimeOut = 999999999

Colocando assim resolveu, tinha um outro erro no script q tbém resolvi.

Muito obrigado galera pela ajuda!!

Vcs são os caras hehehehehe http://forum.imasters.com.br/public/style_emoticons/default/clap.gif

abraços

hargon · Agosto 11, 2008

Bacana. http://forum.imasters.com.br/public/style_emoticons/default/thumbsup.gif

Abraço

Arquivado

[Resolvido] Barra de Status/Progresso de envio de arquivo usando ASPUp

Recommended Posts

BelSelf (Silvano Soares) 0

Compartilhar este post

Link para o post

Compartilhar em outros sites

jrcardozo 4

Compartilhar este post

Link para o post

Compartilhar em outros sites

Ted k' 126

Compartilhar este post

Link para o post

Compartilhar em outros sites

BelSelf (Silvano Soares) 0

Compartilhar este post

Link para o post

Compartilhar em outros sites

BelSelf (Silvano Soares) 0

Compartilhar este post

Link para o post

Compartilhar em outros sites

hargon 64

Compartilhar este post

Link para o post

Compartilhar em outros sites

BelSelf (Silvano Soares) 0

Compartilhar este post

Link para o post

Compartilhar em outros sites

hargon 64

Compartilhar este post

Link para o post

Compartilhar em outros sites

BelSelf (Silvano Soares) 0

Compartilhar este post

Link para o post

Compartilhar em outros sites

BelSelf (Silvano Soares) 0

Compartilhar este post

Link para o post

Compartilhar em outros sites

Ted k' 126

Compartilhar este post

Link para o post

Compartilhar em outros sites

BelSelf (Silvano Soares) 0

Compartilhar este post

Link para o post

Compartilhar em outros sites

hargon 64

Compartilhar este post

Link para o post

Compartilhar em outros sites

PHP+Codeigniter - Dúvida em Relação a Teclas

Conexão mysql com outro domínio

[Resolvido] JavaScript - Exibir logo dentro da Tabela html

Fóruns

Tempo Real

Informação importante