Sitema De Uplaod Sem Componentes...

marcus Gemeos · Abril 6, 2006

Olá pessoal,

Para quem precisa realmente de um sistema de upload, esse sistema abaixo é de uplaod sem componentes, então roda em qualquer servidor perfeitamente!

Esse sistema é composto do arquivo "upload.asp" e do arquivo "upload.inc", esse último é chamado pelo "upload.asp" em comando CODEcomo vocês iram vê nos códigos abaixo.

O sistema abaixo tem opções a mais ativas em: Não permitir arquivos não imagens, não permitir que usuários escrevam no campo do upload, limita o tamanho de arquivos (imagens) a ser enviadas. Só faltou a opção de renomear arquivos antes de enviar, que seria uma boa também, mas infelizmente não tem mas vocês poderam acrescentar essa opção sem problemas!

Os códigos abaixo não precisam praticamente de alteração nenhuma, só vocês prestarem atenção no local (diretório ou pasta) onde irão serem enviadas as imagens ao servidor.

Para você criar o arquivo "uplaod.inc", você poderá fazer perfeitamente em um bloco de notas, na hora de salvar os códigos aqui disponíveis, vá no menu "Salvar como..." escreva no campo adequado "upload.inc" não esquecendo de deixar o campo "Salvar como tipo" em *.txt e sim em *.*, ou seja, todos os arquivos, entenderam né? E salva e pronto, o arquivo terá extençao *.inc.

Abaixo segue os códigos completos de cada arquivo (upload.asp e upload.inc)

Críticas, só fazerem se quiserem!

Abraços!

Marcus

upload.asp

<%
byteCount = Request.TotalBytes
'RequestBin = Request.BinaryRead(byteCount)

%>
<html>
<head>
<title>SISTEMA DE UPLOAD DE QUALQUER ARQUIVO</title>
<script LANGUAGE="JavaScript">
function Limit(upload) {
if (upload.file.value == "") { 
alert("Informe o nome do arquivo (.jpg ou .gif)!"); 
upload.file.focus(); 
return false; 
} 
vfile = upload.file.value; 
tfile = vfile.length; 

if ((vfile.substr(tfile - 4, 4) != ".jpg") & (vfile.substr(tfile - 4, 4) != ".gif")){ 
alert("O arquivo deverá possuir o formato (.jpg ou .gif)!"); 
upload.file.focus(); 
return false; 
} 
}
</script>

</head>
<body>

  <form name=upload OnKeyPress="return false;" OnSubmit= "return Limit(upload);" method=post ENCTYPE="multipart/form-data">
    Arquivo : <input type="file" name="file" size="20"><br>
    <input type=submit Name="Action" value="Upload do Arquivo">
  </form></input></input>
</body></HTML>

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

<%

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

If byteCount > 200000 Then
Response.write "Tamanho do arquivo: <font color='red'>" & byteCount & "</font><br>" 
Response.Write "<center>Não deu certo...</center>"
Response.End
End If
  
'ALTERE A PASTA CHAMADA "imgs" PELA PASTA QUE VOCÊ QUER DEIXAR AS IMGENS 
'LEMBRANDO QUE DEVE ESTAR NO MESMO DIRETORIO DAS PAGINAS UPLOAD.ASP E UPLOAD.INC
'DEIXE A BARRA "/" - PARA USAR NO SEU SITE
'DEIXE A BARRA "\" - PARA USAR NA SUA INTRANET

  FilePath = Server.MapPath("imgs") & "\" & Fields("file").FileName
  Fields("file").Value.SaveAs FilePath
End If
'BY - ROBERTO GODOY
%>

upload.inc

'BYROBERTO GODOY - SAMPA - SP - BRASIL
<script RUNAT=SERVER LANGUAGE=VBSCRIPT>
Const IncludeType = 2

Dim UploadSizeLimit

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

      
      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
      
      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", "ERR 10"
      End If
    Else
      Err.Raise 11, "GetUpload", "ERR 11"
    End If
  Else
    Err.Raise 1, "GetUpload", "ERR 10"
  End If
  Set GetUpload = Result
End Function

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)

    Dim HeaderContent, FieldContent, bFieldContent

    Dim Content_Disposition, FormFieldName, SourceFileName, Content_Type

    Dim Field, TwoCharsAfterEndBoundary

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

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

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

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

    Set Field = CreateUploadField()'See the JS function bellow
    Set FieldContent = CreateBinaryData(bFieldContent,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

    Fields.Add FormFieldName, Field

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

    If Not isLastBoundary Then 
      PosOpenBoundary = PosCloseBoundary
      PosCloseBoundary = InStrB(PosOpenBoundary + LenB(Boundary), Binary, Boundary)
    End If
  Loop
  Set SeparateFields = Fields
End Function

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

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

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)

  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>

ibreak · Abril 12, 2006

Marcus testei o seu sistema de upload e é muito legal, funciona que é uma beleza... De vários que eu testei é o mais fácil de usar...

Eu vi que você disse o seguinte,

Só faltou a opção de renomear arquivos antes de enviar, que seria uma boa também, mas infelizmente não tem mas vocês poderam acrescentar essa opção sem problemas!

Alguém pode me ajudar a criar essa opção para renomear os arquivos antes de enviar...

Muito obrigado e parabéns... quem não pegou, pega aqui... bem legal mesmo...

marcus Gemeos · Maio 25, 2006

Olá amigo,

É realmente só falta a renomeção de arquivos!

Quem tiver disposição...

Fico feliz em ter lhe ajudado!

Abração!

Marcus

Entrar

Sitema De Uplaod Sem Componentes...

Pergunta

marcus Gemeos

Link para o comentário

Compartilhar em outros sites

2 respostass a esta questão

Posts Recomendados

ibreak

Link para o comentário

Compartilhar em outros sites

marcus Gemeos

Link para o comentário

Compartilhar em outros sites

Participe da discussão

Estatísticas dos Fóruns

Navegação

Atividades