Ir para conteúdo

POWERED BY:

Arquivado

Este tópico foi arquivado e está fechado para novas respostas.

mvca

Criar pasta e fazer Upload

Por , em ASP Clássico

Recommended Posts

mvca    0

mvca
Postado

Galera, to precisando de uma ajuda de você. Preciso fazer um sisteminha de upload. Preciso que esse sistema crie uma pasta, ou seja form 1, e um pra fazer o upload pra essa pagina, ou seja form2. Como posso fazer isso, eu estou utilizando aqueles script de upload sem documento, mas nao consigo mandar para pasta o scripts é esse:

 

upload.asp

 

<html>

<head>

<title>Upload de fichier</title>

</head>

<body>

 

<form method=post ENCTYPE="multipart/form-data">

 

<select name="pasta" size="1">

<option value="0" selected>Escolha uma pagina</option>

<option value="img01">Pasta 01</option>

<option value="img02">Pasta 02</option>

</select>

 

File1 : <input type="file" name="File1"><br>

 

File2 : <input type="file" name="File2"><br>

 

 

<input type="submit" Name="Action" value="Upload the file">

</form>

</body></HTML>

 

<!---#INCLUDE FILE="upload.inc" --->

 

<%

 

'Sauvegarde le fichier 'File1' sur le serveur dans le même répertoire que ce script

'Modifier le FilePath pour le claquer ailleurs

pasta = request.form("pasta")

If Request.ServerVariables("REQUEST_METHOD") = "POST" Then 'Request method must be "POST" For get the fields

 

Set Fields = GetUpload()

FilePath1 = Server.MapPath(".") & "\" & Fields("File1").FileName

Fields("File1").Value.SaveAs FilePath1

FilePath2 = Server.MapPath(".") & "\" & Fields("File2").FileName

Fields("File2").Value.SaveAs FilePath2

 

End If

 

%>

 

e o outro

 

upload.inc

 

<script RUNAT=SERVER LANGUAGE=VBSCRIPT>

Const IncludeType = 2

 

'Vous pouvez utiliser ce composant d'upload pourr :

' 1. Uploader de petits fichiers sur le serveur (sauvegarde via les FileSystem object)

' 2. Uploader des fichiers binaires/texte de n'importe quelle taille sur une base de données serveur (RS("BinField") = Upload("FormField").Value)

 

 

'restriction de la taille de l'upload

Dim UploadSizeLimit

 

'********************************** Méthode GetUpload **********************************

'Cette fonction lit les champs de formulaires en entrée binaire et les renvoie en tant qu'objet du dictionnaire.

 

Function GetUpload()

Dim Result

Set Result = Nothing

If Request.ServerVariables("REQUEST_METHOD") = "POST" Then 'la méthode REQUEST doit être POST

Dim CT, PosB, Boundary, Length, PosE

CT = Request.ServerVariables("HTTP_Content_Type") ' lit le header

If LCase(Left(CT, 19)) = "multipart/form-data" Then 'qui doit être de type "multipart/form-data"

 

 

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

If PosB > 0 Then Boundary = Mid(CT, PosB + 9) 'Separetes boundary

 

'****** Erreur sur IE5.01 - doublement des entêtes http

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

If PosB > 0 then 'Patch pour l'erreur IE

PosB = InStr(Boundary, ",")

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

end if

'****** Erreur sur IE5.01 - doublement des entêtes http

 

Length = CLng(Request.ServerVariables("HTTP_Content_Length"))

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

Boundary = "--" & Boundary

Dim Head, Binary

Binary = Request.BinaryRead(Length) 'lit les données à partir du poste client

 

 

Set Result = SeparateFields(Binary, Boundary)

Binary = Empty 'Mise à jour des variables

Else

Err.Raise 10, "GetUpload", "longueur nulle ."

End If

Else

Err.Raise 11, "GetUpload", "Pas de fichier joint."

End If

Else

Err.Raise 1, "GetUpload", "Mauvaise méthode de request."

End If

Set GetUpload = Result

End Function

 

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

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)

'Entête et fichier source

Dim HeaderContent, FieldContent, bFieldContent

'entêtes

Dim Content_Disposition, FormFieldName, SourceFileName, Content_Type

'variable

Dim Field, TwoCharsAfterEndBoundary

'Fin de l'entête

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

 

'Séparation des champs de l'entêter

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

 

'séparation du contenu

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

 

'séparation des champs d'entête de l'entêter

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

 

'Creation d'un champs et attribution des paramètres

Set Field = CreateUploadField()'See the JS function bellow

Set FieldContent = CreateBinaryData(bFieldContent,LenB(bFieldContent))

' FieldContent.ByteArray = bFieldContent

' FieldContent.Length = LenB(bFieldContent)

 

Field.Name = FormFieldName

Field.ContentDisposition = Content_Disposition

Field.FilePath = SourceFileName

Field.FileName = GetFileName(SourceFileName)

Field.ContentType = Content_Type

Field.Length = FieldContent.Length

Set Field.Value = FieldContent

 

' response.write "<br>:" & FormFieldName

Fields.Add FormFieldName, Field

 

'Dernière borne ?

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

isLastBoundary = TwoCharsAfterEndBoundary = "--"

 

If Not isLastBoundary Then 'Putain!!! Pas la dernière... on avance jusqu'au champ suivant.

PosOpenBoundary = PosCloseBoundary

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

End If

Loop

Set SeparateFields = Fields

End Function

 

'********************************** Utilities **********************************

 

'Separation des champs d'entête de l'entête uploadé

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

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

 

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

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

 

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

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

 

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

End Function

 

'Separation du champ entre sStart et 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

 

'Separation du nom de fichier du chemin

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

 

 

 

Function BinaryToStringSimple(Binary)

Dim I, S

For I = 1 To LenB(Binary)

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

Next

BinaryToStringSimple = S

End Function

 

Function BinaryToString(Binary)

' BinaryToString = RSBinaryToString(Binary)

' Exit Function

 

 

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

BinaryToString = pl1 & pl2 & pl3

End Function

 

 

Function RSBinaryToString(xBinary)

 

Dim Binary

 

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)

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 vbsSaveAs(FileName, ByteArray)

Dim FS, TextStream

Set FS = CreateObject("Scripting.FileSystemObject")

 

Set TextStream = FS.CreateTextFile(FileName)

 

TextStream.Write BinaryToString(ByteArray) ' BinaryToString is in upload.inc.

TextStream.Close

End Function

 

 

</SCRIPT>

<script RUNAT=SERVER LANGUAGE=JSCRIPT>

 

function CreateUploadField(){ return new uf_Init() }

function uf_Init(){

this.Name = null

this.ContentDisposition = null

this.FileName = null

this.FilePath = null

this.ContentType = null

this.Value = null

this.Length = null

}

 

 

function CreateBinaryData(Binary, mLength){ return new bin_Init(Binary, mLength) }

function bin_Init(Binary, mLength){

this.ByteArray = Binary

this.Length = mLength

this.String = BinaryToString(Binary)

this.SaveAs = jsSaveAs

}

//function jsBinaryToString(){

// return BinaryToString(this.ByteArray)

//};

function jsSaveAs(FileName){

return vbsSaveAs(FileName, this.ByteArray)

}

//Simulate ByteArray class by JS/VBS - end

 

</SCRIPT>

 

 

Por favor me ajudem!!!

Obrigado pela atenção!!!

 

Marcus

Compartilhar este post

Link para o post
Compartilhar em outros sites

mvca    0

mvca
Postado

Caros colegas continuo martelando nesse mesmo assunto pois preciso disso para terminar um sistema de fotos bem legal, e quando terminar vou disponibilizar pra vcs.Mais preciso desse upload, para que fique bem legal.Por favor me ajudem!!! Os mestres da programação web me ajudem !!!Obrigado pela atenção.Marcus

Compartilhar este post

Link para o post
Compartilhar em outros sites

hinom    5

hinom
Postado

cara, não te mandei ainda porque tow com uns problemas pra rodar asp no xp pro..

 

vou mandar um script de upload que tenho, não pude testá-lo ainda, mas funciona com winnt e win9x:

 

 

para testar, crie uma pasta chamada "tmp" no mesmo diretorio onde salvar o scripts..

o nome da pasta pra inde vão os arquivos você especifica em

session("EnviarAux")

 

 

obs: não requer componente

 

 

 

 

default.asp

 

<%session("EnviarAux") = "tmp\"%><html><head><title>UPLOAD</title><link href=css/estilos2.css rel=stylesheet type=text/css></style></head><body bgcolor=ffffff text=000000 cellspacing=0 cellpadding=0 topmargin=0 leftmargin=0 marginwidth=0 marginheight=0 margin=0px border=0><center><table width=100% height=100% cellspacing=0 cellpadding=0 border=0 class=texto><tr><td align=center valign=middle><!-- inicio --><B>E n v i a r    A r q u i v o</b><div align=left style=width:200px;><FORM METHOD="Post" ENCTYPE="multipart/form-data" ACTION="upload.asp"><INPUT TYPE="file" size=20 NAME="File1" class=entrada><br><INPUT TYPE="file" size=20 NAME="File2" class=entrada><br><INPUT TYPE="file" size=20 NAME="File3" class=entrada><br><INPUT TYPE="file" size=20 NAME="File4" class=entrada><p><br></div><INPUT TYPE="submit" NAME="Enter" value=" enviar " class=botao>      <input type=button value=fechar onclick=javascript:window.close('del'); onkeydown=javascript:window.close('del'); onkeypress=javascript:window.close('del'); class=botao></FORM><!-- fim --><!-- <%=session("EnviarAux")%> --></td></tr></table></center></body></html>

 

 

 

 

 

upload.asp

 

<%On Error Resume NextForWriting = 2lngNumberUploaded = 0noBytes = Request.TotalBytes binData = Request.BinaryRead (noBytes)Set RST = CreateObject("ADODB.Recordset")LenBinary = LenB(binData)	if LenBinary > 0 Then	RST.Fields.Append "myBinary", 201, LenBinary	RST.Open	RST.AddNew	RST("myBinary").AppendChunk BinData	RST.Update	strDataWhole = RST("myBinary")	End ifstrBoundry = Request.ServerVariables ("HTTP_CONTENT_TYPE")lngBoundryPos = instr(1,strBoundry,"boundary=") + 8 strBoundry = "--" & right(strBoundry,len(strBoundry)-lngBoundryPos)lngCurrentBegin = instr(1,strDataWhole,strBoundry)lngCurrentEnd = instr(lngCurrentBegin + 1,strDataWhole,strBoundry) - 1	Do While lngCurrentEnd > 0	strData = mid(strDataWhole,lngCurrentBegin, lngCurrentEnd - lngCurrentBegin)	strDataWhole = replace(strDataWhole,strData,"")	lngBeginFileName = instr(1,strdata,"filename=") + 10	lngEndFileName = instr(lngBeginFileName,strData,chr(34))   if lngBeginFileName <> lngEndFileName and lngBeginFileName - 10 <> 0 Then  strFilename = mid(strData,lngBeginFileName,lngEndFileName - lngBeginFileName)  tmpLng = instr(1,strFilename,"\") 	 Do While tmpLng > 0 	 PrevPos = tmpLng 	 tmpLng = instr(PrevPos + 1,strFilename,"\") 	 Loop  FileName = right(strFilename,len(strFileName) - PrevPos)  lngCT = instr(1,strData,"Content-Type:") 	 if lngCT > 0 Then 	 lngBeginPos = instr(lngCT,strData,chr(13) & chr(10)) + 4 	 else 	 lngBeginPos = lngEndFileName 	 End if  lngEndPos = len(strData)   lngDataLenth = lngEndPos - lngBeginPos  strFileData = mid(strData,lngBeginPos,lngDataLenth)	  dir2 = Session("EnviarAux")  Set fso = CreateObject("Scripting.FileSystemObject")  path = mid(Server.MapPath("upload.asp"),1,instr(1,Server.MapPath("upload.asp"),"upload.asp",1)-1) 	 if dir2 <> "" then 	 path = path&dir2&"\" 	 path = replace(path,dirGere,"") 	 else 	 path = replace(path,dirGere,"") 	 end if  Set f = fso.OpenTextFile(path & FileName, ForWriting, True)  f.Write strFileData  Set f = nothing  Set fso = nothing  lngNumberUploaded = lngNumberUploaded + 1  End if	lngCurrentBegin = instr(1,strDataWhole,strBoundry)	lngCurrentEnd = instr(lngCurrentBegin + 1,strDataWhole,strBoundry) - 1	loop function ParseForm(strFieldName)	strFormData = teste	lngNamePos = instr(1,strFormData,"name=" & chr(34) & strFieldName & chr(34))  if lngNamePos = 0 Then  ParseForm="não"  Else  lngBeginFieldData = instr(lngNamePos,strFormData,vbcrlf & vbcrlf)+4 	 if strFieldName <> "texto" then  	 lngEndFieldData = instr(lngBeginFieldData,strFormData,vbcrlf) 	 else 	 lngEndFieldData = instr(lngBeginFieldData,strFormData,"*") 	 end if  ParseForm=mid(strFormData,lngBeginFieldData,lngEndFieldData-lngBeginFieldData)  End ifEnd function	If Err <> 0 Then	Response.Write "Erro:-> " & Err.Description	else	resposta = " Transmissão Efetivada com Sucesso !!!"	end if%><%=resposta%>

Compartilhar este post

Link para o post
Compartilhar em outros sites

mvca    0

mvca
Postado

O problema que estou tendo é com relação a pasta pra onde vou enviar a imagem, pois não quero uma pasta fixa, quero no formulário eu mesmo escolher a pasta.Se puder ajudar ainda mais um pouco!!!Obrigado pela atençãoMarcus

Compartilhar este post

Link para o post
Compartilhar em outros sites

hinom    5

hinom
Postado

com esse script que te passei só conseguia fazê-lo funcionar se não passasse nenhum outro parâmetro que não fosse do tipo file, por isso tive que usar session:<%session("EnviarAux") = "tmp\"%>eu usava isso num gerenciador de arquivos, quando clicava no botão "upload" já enviava junto um parâmetro que especificasse o diretório, tipo:<a href="upload_form.asp?dir=tmp\">upload</a>"upload_form.asp"<%dir = request.querystring("dir")session("EnviarAux") = dir%>sacou ?

Compartilhar este post

Link para o post
Compartilhar em outros sites

mvca    0

mvca
Postado

Caro colega fucionaou perfeitamente, você show de bolaObrigado, você me salvouAgora só preciso de um script para criar diretórios, se não for pedir demais, já que eu pedi muito.ObrigadoMarcus

Compartilhar este post

Link para o post
Compartilhar em outros sites

hinom    5

hinom
Postado

<%pasta = "teste_dir"caminho = server.mappath(pasta)'## cria pastaset fso = Server.CreateObject("Scripting.FileSystemObject") if fso.FolderExists (caminho)=false then fso.CreateFolder caminho%> <script language=javascript> alert("\n<%=pasta%>\ncriado com sucesso!!\n"); </script> <%else%> <script language=javascript> alert("\nesta pasta já existe\nescolha outro nome\n"); </script> <%end ifSet fsoObject = Nothing%>

Compartilhar este post

Link para o post
Compartilhar em outros sites

mvca    0

mvca
Postado

Po cara você é fera, so falta agora você me dizer como eu mudo o nome da imagem na hora de cadastrar. Ou seja no formulário de upload eu coloco um nome para minha imagem.Pode me ajudar novamente???Já estou sem graça de te pedir tanta ajuda.Valeu pela atençãoMarcus

Compartilhar este post

Link para o post
Compartilhar em outros sites

hinom    5

hinom
Postado

cara tow com problemas pra rodar asp no xp pro..

 

 

tenta encontrar essa parte do codigo no upload.asp:

 

...Set f = fso.OpenTextFile(path & [B]FileName[/B], ForWriting, True) f.Write strFileData Set f = nothing Set fso = nothing...

em negrito, é a variável que recebe o nome do arquivo..

tente modificar assim:

 

 

 

...FileName = "novo_nome.extensão";Set f = fso.OpenTextFile(path & [B]FileName[/B], ForWriting, True) f.Write strFileData Set f = nothing Set fso = nothing...

 

 

 

acho que isso deve recolver..

Compartilhar este post

Link para o post
Compartilhar em outros sites
Ir para a lista de tópicos ASP Clássico
×

Informação importante

Ao usar o fórum, você concorda com nossos Termos e condições.

  Aceito