Código Upload -

[thicomp 0]

Oi galera, tenho este código para upload de arquivos, mas preciso colocar um dois botões radio para que o usuario selecione o desejado, e que dependendo da seleção, ele vai enviar o documento para uma determinada pasta no sistema. Teria que fazer um if na parte em vermelho, mas quando testo com "if" está me retornando um erro, enquanto que executando do jeito que está ele funciona legal. Alguem pode me ajudar???

 

<%@ Language=VBScript %>

<%

Dim Contador, Tamanho

Dim ConteudoBinario, ConteudoTexto

Dim Delimitador, Posicao1, Posicao2

Dim ArquivoNome, ArquivoConteudo, PastaDestino

Dim objFSO, objArquivo

 

PastaDestino = Server.MapPath("/cm/tutor")

 

'Determina o tamanho do conteúdo

Tamanho = Request.TotalBytes

 

'Obtém o conteúdo no formato binário

ConteudoBinario = Request.BinaryRead(Tamanho)

 

'Transforma o conteúdo binário em string

For Contador = 1 To Tamanho

ConteudoTexto = ConteudoTexto & Chr(AscB(MidB(ConteudoBinario, Contador, 1)))

Next

 

'Determina o delimitador de campos

Delimitador = Left(ConteudoTexto, InStr(ConteudoTexto, vbCrLf) - 1)

 

'Percorre a String procurando os campos

'identifica os arquivo e grava no disco

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

 

Posicao1 = InStr(ConteudoTexto, Delimitador) + Len(Delimitar)

 

do while True

ArquivoNome = ""

Posicao1 = InStr(Posicao1, ConteudoTexto, "filename=")

if Posicao1 = 0 then

exit do

else

'Determina o nome do arquivo

Posicao1 = Posicao1 + 10

Posicao2 = InStr(Posicao1, ConteudoTexto, """")

For contador = (Posicao2 - 1) to Posicao1 step -1

if Mid(ConteudoTexto, Contador, 1) <> "\" then '"

ArquivoNome = Mid(ConteudoTexto, Contador, 1) & ArquivoNome

else

exit for

end if

next

 

'Determina o conteúdo do arquivo

Posicao1 = InStr(Posicao1, ConteudoTexto, vbCrLf & vbCrLf) + 4

Posicao2 = InStr(Posicao1, ConteudoTexto, Delimitador) - 2

ArquivoConteudo = Mid(ConteudoTexto, Posicao1, (Posicao2 - Posicao1 + 1))

 

'Grava o arquivo

if ArquivoNome <> "" then

Set objArquivo = objFSO.CreateTextFile(PastaDestino & "\" & ArquivoNome, true)

objArquivo.WriteLine ArquivoConteudo

objArquivo.Close

 

Response.write "Arquivo " & _

ArquivoNome & " foi gravado com sucesso!<br>"

Set objArquivo = nothing

end if

end if

Loop

Set objFSO = nothing

%>

[fercosmig 0]

posta ae o if que está dando erro

 

If Request.Form("radio") = "aaa" thenPastaDestino = Server.MapPath("/cm/tutor")ElsePastaDestino = Server.MapPath("/cm/outro")End If

ou case se for mais de 2 opções

 

Select case Request.Form("radio")Case "aaa"PastaDestino = Server.MapPath("/cm/tutor")Case "bbb"PastaDestino = Server.MapPath("/cm/outro")Case "ccc"PastaDestino = Server.MapPath("/cm/outra")End Select

abraços

[thicomp 0]

O problema é que eu já tinha colocado este bloco de comando na página, mas me retorna este erro:Request object error 'ASP 0206 : 80004005' Cannot call BinaryRead /Cristalia/cm/upload.asp, line 24 Cannot call BinaryRead after using Request.Form collection.

[fcorrea 0]

Quando você utiliza formulario do tipo MULTIPART/FORM-DATA, você nao consegue utilizar Request no mesmo depois de utilizar binary Read.

 

Abaixo estou inserindo um arquivo que você deverá criar um include com o mesmo e tudo que for fazer request utilize a funcao buscaCampo do mesmo que ela busca por requerst ou binaryRead sem dar erro.

 

Da uma olhada no forum abaixo que possiu a mesma duvida que você e eu tbm possuia e resolvi

http://forum.imasters.com.br/index.php?showtopic=148913

 

 

 

 

CODIGO INC_UPLOAD.ASP

 

<%

'Busca campo quando for POST o form (Fields), ou nao (Request)

Function buscaCampo(ByVal sNomeCampo)

If Request.ServerVariables("REQUEST_METHOD") = "POST" Then

On Error Resume Next

buscaCampo = Fields(sNomeCampo).Value.String

Else

buscaCampo = Request(sNomeCampo)

End If

End Function

 

'Somente instancia Fields quando o metodo for POST

If Request.ServerVariables("REQUEST_METHOD") = "POST" Then

Dim Fields

Set Fields = GetUpload()

End If

 

' Limite do tamanho do upload

Dim UploadSizeLimit

 

'****************************************** GetUpload ****************************************

' Esta função lê todos os campos de formulário da entrada binária e retorna-a como um objeto

' dicionário. O objeto dicionário contém os campos do formulário. Cada campo é representado

' pelos seguintes valores:

' .Name = Nome do campo (<Input Name="..." Type="File,...">)

' .FileName = Nome do arquvo fonte de <input type=file>

' .FilePath = Caminho completo do arquivo fonte

' .ContentType = Content-Type de <input type=file>

' .Value = Conteúdo binário do campo fonte.

' .Length = Tamanho do campo de dado binário

Function GetUpload()

Dim Result

Set Result = Nothing

 

If Request.ServerVariables("REQUEST_METHOD") = "POST" Then ' O método de Request deve ser "POST"

Dim CT, PosB, Boundary, Length, PosE

CT = Request.ServerVariables("HTTP_Content_Type") 'Lê a propriedade Content-Type do cabeçalho

If LCase(Left(CT, 19)) = "multipart/form-data" Then 'Content-Type deve ser "multipart/form-data"

 

' Busca o limite e o tamanho da propriedade Content-Type

PosB = InStr(LCase(CT), "boundary=") 'Encontra o limitador

If PosB > 0 Then Boundary = Mid(CT, PosB + 9) 'Separa o limitador

 

'****** Erro do IE 5.01 - duplica o cabeçalho HTTP

PosB = InStr(LCase(CT), "boundary=")

If PosB > 0 then 'Patch para o erro do IE

PosB = InStr(Boundary, ",")

If PosB > 0 Then Boundary = Left(Boundary, PosB - 1)

end if

'****** Erro do IE 5.01 - duplica o cabeçalho HTTP

 

Length = CLng(Request.ServerVariables("HTTP_Content_Length")) 'Lê a propriedade Content-Length do cabeçalho

If "" & UploadSizeLimit <> "" Then

UploadSizeLimit = CLng(UploadSizeLimit)

If Length > UploadSizeLimit Then

Request.BinaryRead (Length)

Err.Raise 2, "GetUpload", "Upload size " & FormatNumber(Length, 0) & "B exceeds limit of " & FormatNumber(UploadSizeLimit, 0) & "B"

Exit Function

End If

End If

 

If Length > 0 And Boundary <> "" Then 'Há algum conteúdo disponível para upload?

Boundary = "--" & Boundary

Dim Head, Binary

Binary = Request.BinaryRead(Length) 'Lê os dados binários do cliente

 

'Recupera os campos de upload dos dados binários

Set Result = SeparateFields(Binary, Boundary)

Binary = Empty

Else

Err.Raise 10, "GetUpload", "Zero length request ."

End If

Else

Err.Raise 11, "GetUpload", "No file sent."

End If

Else

Err.Raise 1, "GetUpload", "Bad request method."

End If

Set GetUpload = Result

End Function

'****************************************** GetUpload ****************************************

 

 

 

'************************************* SeparateFields ****************************************

' Esta função recupera os campos de upload dos dados binários e retorna os campos como um array.

'Binary é safearray ( VT_UI1 | VT_ARRAY )

Function SeparateFields(Binary, Boundary)

Dim PosOpenBoundary, PosCloseBoundary, PosEndOfHeader, isLastBoundary

Dim Fields

Boundary = StringToBinary(Boundary)

 

PosOpenBoundary = InStrB(Binary, Boundary)

PosCloseBoundary = InStrB(PosOpenBoundary + LenB(Boundary), Binary, Boundary, 0)

 

Set Fields = CreateObject("Scripting.Dictionary")

Do While (PosOpenBoundary > 0 And PosCloseBoundary > 0 And Not isLastBoundary)

' Cabeçalho e arquivo/fonte do campo

Dim HeaderContent, bFieldContent

' Campos de cabeçalho

Dim Content_Disposition, FormFieldName, SourceFileName, Content_Type

' Variáveis auxiliares

Dim TwoCharsAfterEndBoundary

' Busca o fim do cabeçalho

PosEndOfHeader = InStrB(PosOpenBoundary + Len(Boundary), Binary, StringToBinary(vbCrLf + vbCrLf))

 

' Separa os campos do cabeçalho

HeaderContent = MidB(Binary, PosOpenBoundary + LenB(Boundary) + 2, PosEndOfHeader - PosOpenBoundary - LenB(Boundary) - 2)

 

' Separa o conteúdo do campo

bFieldContent = MidB(Binary, (PosEndOfHeader + 4), PosCloseBoundary - (PosEndOfHeader + 4) - 2)

 

' Recupera os campos do cabeçalho

GetHeadFields BinaryToString(HeaderContent), FormFieldName, SourceFileName, Content_Disposition, Content_Type

 

' Cria um campo e atribui parâmetros

Dim FieldContent ' Conteúdo binário dos campos

Dim Field ' Todos os valores do campo

Set Field = New clField

Set FieldContent = New clByteArray

FieldContent.ByteArray = bFieldContent

 

Set Field.Value = FieldContent

Field.Name = FormFieldName

Field.ContentDisposition = Content_Disposition

Field.FilePath = SourceFileName

Field.FileName = GetFileName(SourceFileName)

Field.ContentType = Content_Type

Field.Length = FieldContent.Length

 

Dim dField

dField = Fields(FormFieldName)

if isempty (dField) then ' Esta é a primeira ocorrência de um nome do campo fonte.

Set Fields(FormFieldName) = Field

else ' Segunda ocorrência de um nome de campo fonte. Este é um multiselect ou algo similar.

if isarray(dField) then ' Há um array de valores no campo do dicionário debaixo desta chave. Adicione um novo valor no array.

ReDim Preserve dField(ubound(dField)+1)

Set dField(ubound(dField) - 1) = Field

else ' Há um valor no campo do dicionário debaixo desta chave. Criar um array do antigo e novo valor.

dField = Array(dField, Field)

end if

Fields(FormFieldName) = dField

end if

 

' É o último limitador?

TwoCharsAfterEndBoundary = BinaryToString(MidB(Binary, PosCloseBoundary + LenB(Boundary), 2))

isLastBoundary = TwoCharsAfterEndBoundary = "--"

 

If Not isLastBoundary Then ' Este não é o último limitador - vai para o próximo campo.

PosOpenBoundary = PosCloseBoundary

PosCloseBoundary = InStrB(PosOpenBoundary + LenB(Boundary), Binary, Boundary)

End If

Loop

Set SeparateFields = Fields

End Function

'************************************* SeparateFields ****************************************

 

 

 

'*********************************** Utilitários Upload **************************************

' Separa os campos de cabeçalho do cabeçalho upload

Function GetHeadFields(ByVal Head, Name, FileName, Content_Disposition, Content_Type)

' Busca o nome do campo. Nome é separado por name= e ;

Name = (SeparateField(Head, "name=", ";"))

' Remove aspas (se o nome do campo está entre aspas)

If Left(Name, 1) = """" Then Name = Mid(Name, 2, Len(Name) - 2)

 

' O mesmo para a propriedade filename

FileName = (SeparateField(Head, "filename=", ";"))

If Left(FileName, 1) = """" Then FileName = Mid(FileName, 2, Len(FileName) - 2)

 

' Separa os campos de cabeçalho content-disposition e content-type

Content_Disposition = LTrim(SeparateField(Head, "content-disposition:", ";"))

Content_Type = LTrim(SeparateField(Head, "content-type:", ";"))

End Function

 

' Separa um campo entre sStart e sEnd

Function SeparateField(From, ByVal sStart, ByVal sEnd)

Dim PosB, PosE, sFrom

sFrom = LCase(From)

PosB = InStr(sFrom, sStart)

If PosB > 0 Then

PosB = PosB + Len(sStart)

PosE = InStr(PosB, sFrom, sEnd)

If PosE = 0 Then PosE = InStr(PosB, sFrom, vbCrLf)

If PosE = 0 Then PosE = Len(sFrom) + 1

SeparateField = Mid(From, PosB, PosE - PosB)

Else

SeparateField = Empty

End If

End Function

 

' Separa o nome do arquivo do caminho completo do arquivo

Function GetFileName(FullPath)

Dim Pos, PosF

PosF = 0

For Pos = Len(FullPath) To 1 Step -1

Select Case Mid(FullPath, Pos, 1)

Case ":", "/", "\": PosF = Pos + 1: Pos = 0

End Select

Next

If PosF = 0 Then PosF = 1

GetFileName = Mid(FullPath, PosF)

End Function

'******************************** Utilitários Upload ****************************************

 

 

 

'***************************** Funções de conversão de String *******************************

Function BinaryToString(Binary)

' Seleciona o melhor algoritmo para converter dado binário para String

Dim TempString

 

On Error Resume Next

TempString = RSBinaryToString(Binary)

If Len(TempString) <> LenB(Binary) then 'Erro na converção

' Deve ser usado a versão multibyte do BinaryToString

TempString = MBBinaryToString(Binary)

end if

BinaryToString = TempString

End Function

 

Function MBBinaryToString(Binary)

' Versão MultiByte da função BinaryToString

dim cl1, cl2, cl3, pl1, pl2, pl3

Dim L', nullchar

cl1 = 1

cl2 = 1

cl3 = 1

L = LenB(Binary)

 

Do While cl1<=L

pl3 = pl3 & Chr(AscB(MidB(Binary,cl1,1)))

cl1 = cl1 + 1

cl3 = cl3 + 1

if cl3>300 then

pl2 = pl2 & pl3

pl3 = ""

cl3 = 1

cl2 = cl2 + 1

if cl2>200 then

pl1 = pl1 & pl2

pl2 = ""

cl2 = 1

End If

End If

Loop

MBBinaryToString = pl1 & pl2 & pl3

End Function

 

 

Function RSBinaryToString(xBinary)

' Esta função converte dado binário (VT_UI1 | VT_ARRAY or String MultiByte)

' para string (BSTR) usando ADO recordset.

' Use esta função ao invés de MBBinaryToString se você tem ADODB.Recordset instalado

' a fim de eliminar problemas de performance.

 

Dim Binary

' Dado MultiByte deve ser convertido para VT_UI1 | VT_ARRAY primeiro.

if vartype(xBinary) = 8 then Binary = MultiByteToBinary(xBinary) else Binary = xBinary

 

Dim RS, LBinary

Const adLongVarChar = 201

Set RS = CreateObject("ADODB.Recordset")

LBinary = LenB(Binary)

 

if LBinary>0 then

RS.Fields.Append "mBinary", adLongVarChar, LBinary

RS.Open

RS.AddNew

RS("mBinary").AppendChunk Binary

RS.Update

RSBinaryToString = RS("mBinary")

Else

RSBinaryToString = ""

End If

End Function

 

Function MultiByteToBinary(MultiByte)

' Esta função converte multibyte string para dado binário real (VT_UI1 | VT_ARRAY)

' usando recordset

Dim RS, LMultiByte, Binary

Const adLongVarBinary = 205

Set RS = CreateObject("ADODB.Recordset")

LMultiByte = LenB(MultiByte)

if LMultiByte > 0 then

RS.Fields.Append "mBinary", adLongVarBinary, LMultiByte

RS.Open

RS.AddNew

RS("mBinary").AppendChunk MultiByte & ChrB(0)

RS.Update

Binary = RS("mBinary").GetChunk(LMultiByte)

End If

MultiByteToBinary = Binary

End Function

 

Function StringToBinary(String)

Dim I, B

For I=1 to len(String)

B = B & ChrB(Asc(Mid(String,I,1)))

Next

StringToBinary = B

End Function

 

Function BinaryToStringSimple(Binary)

' Idéia de conversão Multibyte. Não utilizado.

Dim I, S

For I = 1 To LenB(Binary)

S = S & Chr(AscB(MidB(Binary, I, 1)))

Next

BinaryToStringSimple = S

End Function

'**************************** String conversion fuctions ************************************

 

 

 

' Esta função simula a gravação de dado binário usando conversão para uma string e filesystemobject

Function SaveBinaryData(FileName, ByteArray)

Dim FS : Set FS = CreateObject("Scripting.FileSystemObject")

Dim TextStream : Set TextStream = FS.CreateTextFile(FileName)

TextStream.Write BinaryToString(ByteArray)

TextStream.Close

End Function

 

 

 

'*************************************** ByteArray class *************************************

Class clByteArray

'bytearray armazenado

public ByteArray

 

Public Default Property Get ba

ba = ByteArray

End Property

 

public Property Get Length

Length = LenB(ByteArray)

End Property

 

public Property Get String

String = BinaryToString(ByteArray)

End Property

 

' Armazena o dado binário em um arquivo.

Public Function SaveAs(FileName)

SaveBinaryData FileName, ByteArray

End Function

End Class

 

Class clField

Public Name, ContentDisposition, FileName, FilePath, ContentType, Value, Length

Public Default Property Get n

n = Name

End Property

End Class

'************************************** ByteArray class **************************************

 

 

 

'*************************************** SaveUpload ******************************************

' Esta função salva no disco os arquivos especificados no formulário

Function SaveUpload(Fields, DestinationFolder)

If DestinationFolder = "" Then DestinationFolder = getPath("")

 

Dim FS

Dim OutFolder

Dim Field

Dim OutLine

 

Set FS = CreateObject("scripting.filesystemobject")

Set OutFolder = FS.GetFolder(DestinationFolder)

 

Dim SaveFileName

 

for each Field in Fields.Items

SaveFileName = empty

 

if IsObject(Field) then

if Field.FileName <> "" then 'Este campo é arquivo de upload

SaveFileName = Field.FileName

end if

end if

 

if not IsEmpty(SaveFileName) then

Field.Value.SaveAs OutFolder & "\" & SaveFileName 'Salva o conteúdo do campo no disco

end if

next

 

'Cria uma linha de mensagem para o cliente

OutLine = OutLine & "Os campos foram gravados na pasta <b>" & OutFolder & "</b>.<br>"

 

OutFolder = Empty 'Clear variables.

SaveUpload = OutLine

End Function

'*************************************** SaveUpload ******************************************

 

 

 

' Retorna o campo ou "-" se o campo for vazio

Function LogF(ByVal F)

If "" & F = "" Then F = "-" Else F = "" & F

F = replace(F, vbCrLf, "%13%10")

F = replace(F, ",", "%2C")

LogF = F

End Function

 

' Retorna o campo ou "-" seo campo for vazio

Function LogFn(ByVal F)

If "" & F = "" Then LogFn = "-" Else LogFn = formatnumber(F, 0)

End Function

 

%>

[thicomp 0]

Vlw kraVou ter que dar uma estudada melhor nisto