[Resolvido] Função para resize em imagem

[wills 0]

Vocês já utilizaram alguma função para dar resize em imagem sem perder a qualidade?

Estou precisando de uma ajudar pois, irei utilizar a mesma imagem em tamanhos diferentes...

[xanburzum 169]

tem uma função que postei no lab. de script, dá uma procurada lá

pode te ajudar

[wills 0]

Eu dei uma olhada sim! Tu utiliza aspJPEG porém, o meu meu problema é utilizar uma imagem com tamanhos diferentes.

Exemplo, tenho a original que é 600x200, certo? Em uma determinada área eu vou utilizar a mesma imagem com 200x200 e em outro lugar 300x150.

 

entendeu?

[xanburzum 169]

olha este exemplo

 

envia uma imagem grande, reduz pra uma dimensão razoável padrão que usará no site e após gera uma miniatura e grava numa pasta separado... veja se te serve e pode modificar a seu critério.

<%
id      = request("id")

On Error Resume Next
Set Upload = Server.CreateObject("Persits.Upload")
Upload.OverwriteFiles = True    ' sobrepõe o arquivo ?
Upload.SetMaxSize 1000000               ' tamanho máximo permitido para envio em KB
Path = "C:/inetpub/vhosts/site.com.br/httpdocs/fotos/"          ' caminho relativo ao site no servidor
Count = Upload.Save(Path)

For Each File in Upload.Files
       foto = File.FileName                    ' pega o nome do arquivo da imagem em uma variável
Next

' REDUZIR TAMANHO DA IMAGEM EM KB
Set File = Upload.Files(1)
Set Jpeg = Server.CreateObject("Persits.Jpeg")
Jpeg.Open( File.Path )
Jpeg.Quality = 70       ' qualidade do JPEG
Jpeg.Width = 640        ' tamanho da largura da foto a ser redimensionada
Jpeg.Height = Jpeg.OriginalHeight * Jpeg.Width / Jpeg.OriginalWidth             ' pega largura e diminui altura proporcional
Jpeg.Sharpen 1, 120
' Grava a imagem na pasta definida acima no Path
SavePath = Path & File.ExtractFileName

If UCase(Right(SavePath, 3)) <> "JPG" Then
 SavePath = SavePath & ".jpg"
End If
jpeg.Save SavePath

' ETAPA PARA GERAÇÃO DA MINIATURA
Set File = Upload.Files(1)
Set Jpeg = Server.CreateObject("Persits.Jpeg")
Jpeg.Open( File.Path )          ' pega o caminho relativo definido no Path
Jpeg.Quality = 80                       ' define a qualidade do JPEG
Jpeg.Width = 120                        ' tamanho da largura a ser criado a miniatura
Jpeg.Height = Jpeg.OriginalHeight * Jpeg.Width / Jpeg.OriginalWidth     ' pega largura e diminui altura proporcional
Jpeg.Sharpen 1, 120
' Grava miniatura da imagem na pasta mini dentro do caminho definido no Path
SavePath = Path & "\mini\" & File.ExtractFileName

If UCase(Right(SavePath, 3)) <> "JPG" Then
 SavePath = SavePath & ".jpg"
End If
jpeg.Save SavePath

Set Jpeg = Nothing


' se houver erro mostra mensagem e volta
If Err <> 0 Then
       Response.Write "Desculpe, houve um erro ao enviar imagens! <br />"
       Response.Write "<a href=""javascript:history.back();"">Voltar</a>"
Else
       ' se não houver erro, grava no banco de dados e mostra mensagem de sucesso
       strSql = ""
       strSql = strSql & " Update tabela SET "
       strSql = strSql & " foto                = '"& File.FileName &"' "
       strSql = strSql & " Where id    = "& id &" "
       cn.execute(strSql)

       ' se houver erro relativo ao gravar no BD mostra mensagem
       if err.number <> 0 then
               Response.Write "Desculpe, houve um erro ao gravar no Banco de Dados! <br />"
               Response.Write "<a href=""javascript:history.back();"">Voltar</a>"
       else
               ' se não houver erro, mostra mensagem de sucesso e encaminha para index ou pagina
       %>
               <script>
                       alert("Dados alterados com sucesso!");
                       window.location='index.asp';
               </script>
       <%
       end if 
End If  
%>

[saloeric 1]

eu uso isso numa função depois é só chamar a imagem e os tamanhos e os locais onde quer guardar

 

sub uploadimg(nome,nomefinal,caminhoactual,caminhofinal,largura,altura)
Set Jpeg = Server.CreateObject("Persits.Jpeg")
Jpeg.Open server.MapPath(caminhoactual&nome)
numHgt = Jpeg.OriginalHeight
numWdt = Jpeg.OriginalWidth
MaxLarg = cint(largura)
MaxAlt  = cint(altura)
	If MaxLarg > numWdt and MaxAlt > numHgt then

	Else
		maxAlt = ((MaxLarg*MaxAlt)/(MaxLarg*numHgt))
		maxLrg = ((MaxLarg*MaxAlt)/(MaxAlt*numWdt))
			If maxAlt < maxLrg then
				width = numWdt*maxAlt
				height = numHgt*maxAlt
			Else
				width = numWdt*maxLrg
				height = numHgt*maxLrg
			End If
		Jpeg.Width = width
		Jpeg.Height = height
	End If
Jpeg.Quality = 100
Jpeg.Save server.MapPath(caminhofinal&nomefinal)
set Jpeg = nothing
end sub


call uploadimg(nome,nomefinal,caminhoactual,caminhofinal,largura,altura)

nome: é o nome da imagem que você vai dar
nomefinal: é se quiser dar outro nome à imagem, para por exemplo guardar na mesma directoria a mesma imagem mas com 2 nomes diferentes
caminhoactual: é o caminho onde se encontra a imagem
caminhofinal: é o caminho onde vai guardar a imagem
largura: não precisa explicar
altura: também não

exemplo de redimensão tendo já feito o upload da imagem

nome_imagem = "teste.jpg"
caminho_imagem = "upload/"
caminho_imagem_2 = "upload/200x200/"

call uploadimg(nome_imagem ,nome_imagem ,caminho_imagem ,caminho_imagem ,600,200)' aqui redimensiona a original
call uploadimg( nome_imagem , nome_imagem , caminho_imagem , caminho_imagem_2 ,200,200) 
...

 

[wills 0]

Eu vou fazer alguns testes.

No caso eu consigo pegar mais de uma imagem que está sendo upada e redimensionar?

 

Eu estou atrás de algum algorítimo ou função que faça isso:

 

<img src="imagem.jpg?500x200"

 

eu já vi isso no .net, mas nunca no asp.....

[xanburzum 169]

você at´pe pode pegar esses paramentros passado pela url e usar outra função para redimensionar conforme a url

[wills 0]

o problema é como fazer isso...

 

eu tentei com aspJPEG.... não gerou erro e nem salvou a thumb... podes me ajudar?

[wills 0]

este é meu código hoje

	on error resume next
	arquivos = "E:\Domains\site.com\wwwroot\homologacao\scharbel\v2\static\upload\liturgia\"	
	Set objUpload = Server.CreateObject("Dundas.Upload.2")
	objUpload.UseVirtualDir = false
	objUpload.UseUniqueNames = false
	objUpload.MaxFileSize = 6000000
	objUpload.Save arquivos	

	DataHora = "{" & RIGHT("0" & Day(Now),2) & "-" & RIGHT("0" & Month(Now),2) & "-" & Year(Now) & "-" & RIGHT("0" & Hour(Now),2) & "-" & RIGHT("0" & Minute(Now),2) & "-" & RIGHT("0" & Second(Now),2) & "}"	
	For Each arquivos in objUpload.Files
		Path = arquivos.Path
		NomeArquivo = objUpload.GetFileName(Path)
		thumb = objUpload.Files(1)

		Set fso = CreateObject("Scripting.FileSystemObject")  
		Set fileObject = fso.GetFile("E:\Domains\site.com\wwwroot\homologacao\scharbel\v2\static\upload\liturgia\" & NomeArquivo)
		fileObject.Name = DataHora&"_"&NomeArquivo
		Set fileObject = Nothing  
		Set fso = Nothing
	Next

 

quando implemento o aspJPEG não acontece nada

[wills 0]

Ai galera consegui!

O erro era bem besta... o caminho estava errado...

 

Obrigado pela ajuda!

[xanburzum 169]

olá amigo, que bom que resolveu, porém , sempre solicito para os users que solucionar seus problemas, que postem o código final, para ser uma refrenecia para outros com a mesma dificuldades.

[delgisa 0]

Saudações

 

Pessoal, sobre essa questão de alterar o tamanho da imagem, me esclareçam uma dúvida:

 

Existe algum código em asp que eu consiga diminuir ou aumentar a imagem proporcionalmente, sem que ela fique distorcida.

Sei que tem vários sistemas de notícias com upload de fotos. Sabemos que as fotos nunca vêm do mesmo tamanho.

Geralmente a gente, ao disponibilizar um local para a imagem ser exibida, já devido qual tamanho deverá ser o Width e o Height.

Atualmente eu pego imagem por imagem, jogo no fireworks e vou mexendo nela até fique do tamanho que eu quero, sem distorcer.

Mas esse procedimento é muito árduo... Será que existe uma código que possa me ajudar?

 

Abraços

 

Jardel Paes

[xanburzum 169]

você consegue fazer isso atraves de componentes

e olha esta função onde no momento do upload da foto, com isso resgatasse as dimensões desta imagem e coloca no bd, com isso você terá as dimensões no bd de todas as imagens, e pode alterá-las também

 

Segue abaixo uma function.

 

<% Option Explicit %>
<% 
Dim address
address = Trim(Request("image"))

Sub CalcImageDimensions()
       Dim objXML, strBinarySource, strAsciiContents
       Dim width, height, colors
       Dim strType

       Set objXML = Server.CreateObject("Microsoft.XMLHTTP")
       strBinarySource = ""
       On Error Resume Next
               objXML.Open "GET", address, False
               objXML.Send
               If Err.Number<>0 Then
                       Response.Write("<font color=""red""><h3>Error " & Err.Number & " : " & Err.Description & "</h3></font>")
               Else  
                       strBinarySource = objXML.ResponseBody
               End If
       On Error Goto 0
       Set objXML=Nothing

       If LenB(strBinarySource)>0 Then
               strAsciiContents = RSBinaryToString(strBinarySource)
               If gfxSpex(strAsciiContents, width, height, colors, strType) = True then
                       Response.Write("image file size: " & LenB(strBinarySource) & " (bytes)<br />")
                       Response.Write("image width: " & width & " (pixels)<br />")
                       Response.Write("image height: " & height & " (pixels)<br />")
                       Response.Write("color depth: " & colors & "<br />")
                       Response.Write("image type: " & strType)
               Else  
                       Response.Write("<font color=""red""><h3>not valid image</h3></font>")
               End If
       End If

       Response.Write("<br /><br /><br />")
End Sub

Function RSBinaryToString(xBinary)
               'RSBinaryToString converts binary data (VT_UI1 | VT_ARRAY Or MultiByte string)
       'to a string (BSTR) using ADO recordset

       Dim Binary
       'MultiByte data must be converted To VT_UI1 | VT_ARRAY first.
       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)
       '© 2000 Antonin Foller, http://www.motobit.com
       ' MultiByteToBinary converts multibyte string To real binary data (VT_UI1 | VT_ARRAY)
       ' Using 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

':::::::::::::::::::::::::::::::::::::::::::::::::  ::::::::::::::::::
':::                                                             :::
':::  This routine will attempt to identify any filespec passed  :::
':::  as a graphic file (regardless of the extension). This will :::
':::  work with BMP, GIF, JPG and PNG files.                     :::
':::                                                             :::
':::::::::::::::::::::::::::::::::::::::::::::::::  ::::::::::::::::::
':::          Based on ideas presented by David Crowell          :::
':::                   (credit where due)                        :::
':::::::::::::::::::::::::::::::::::::::::::::::::  ::::::::::::::::::
':::::::::::::::::::::::::::::::::::::::::::::::::  ::::::::::::::::::
':::::::::::::::::::::::::::::::::::::::::::::::::  ::::::::::::::::::
'::: blah blah blah blah blah blah blah blah blah blah blah blah :::
'::: blah blah blah blah blah blah blah blah blah blah blah blah :::
'::: blah blah     Copyright *c* MM,  Mike Shaffer     blah blah :::
'::: bh blah      ALL RIGHTS RESERVED WORLDWIDE      blah blah :::
'::: blah blah  Permission is granted to use this code blah blah :::
'::: blah blah   in your projects, as long as this     blah blah :::
'::: blah blah      copyright notice is included       blah blah :::
'::: blah blah blah blah blah blah blah blah blah blah blah blah :::
'::: blah blah blah blah blah blah blah blah blah blah blah blah :::
':::::::::::::::::::::::::::::::::::::::::::::::::  ::::::::::::::::::

':::::::::::::::::::::::::::::::::::::::::::::::::  ::::::::::::::::::
':::                                                             :::
':::  This function gets a specified number of bytes from any    :::
':::  file, starting at the offset (base 1)                      :::
':::                                                             :::
':::  Passed:                                                    :::
':::       flnm        => Filespec of file to read               :::
':::       offset      => Offset at which to start reading       :::
':::       bytes       => How many bytes to read                 :::
':::                                                             :::
':::::::::::::::::::::::::::::::::::::::::::::::::  ::::::::::::::::::
Private Function GetBytes(flnm, offset, bytes)
       Dim startPos
       If offset=0 Then
               startPos = 1
       Else  
               startPos = offset
       End If
       if bytes = -1 then              ' Get All!
               GetBytes = flnm
       else
               GetBytes = Mid(flnm, startPos, bytes)
       end if
'               Dim objFSO
'               Dim objFTemp
'               Dim objTextStream
'               Dim lngSize
'               
'               Set objFSO = CreateObject("Scripting.FileSystemObject")
'               
'               ' First, we get the filesize
'               Set objFTemp = objFSO.GetFile(flnm)
'               lngSize = objFTemp.Size
'               set objFTemp = nothing
'               
'               fsoForReading = 1
'               Set objTextStream = objFSO.OpenTextFile(flnm, fsoForReading)
'               
'               if offset > 0 then
'                       strBuff = objTextStream.Read(offset - 1)
'               end if
'               
'               if bytes = -1 then              ' Get All!
'                       GetBytes = objTextStream.Read(lngSize)  'ReadAll
'               else
'                       GetBytes = objTextStream.Read(bytes)
'               end if
'               
'               objTextStream.Close
'               set objTextStream = nothing
'               set objFSO = nothing
End Function

':::::::::::::::::::::::::::::::::::::::::::::::::  ::::::::::::::::::
':::                                                             :::
':::  Functions to convert two bytes to a numeric value (long)   :::
':::  (both little-endian and big-endian)                        :::
':::                                                             :::
':::::::::::::::::::::::::::::::::::::::::::::::::  ::::::::::::::::::
Private Function lngConvert(strTemp)
       lngConvert = clng(asc(left(strTemp, 1)) + ((asc(right(strTemp, 1)) * 256)))
end function

Private Function lngConvert2(strTemp)
       lngConvert2 = clng(asc(right(strTemp, 1)) + ((asc(left(strTemp, 1)) * 256)))
end function

':::::::::::::::::::::::::::::::::::::::::::::::::  ::::::::::::::::::
':::                                                             :::
':::  This function does most of the real work. It will attempt  :::
':::  to read any file, regardless of the extension, and will    :::
':::  identify if it is a graphical image.                       :::
':::                                                             :::
':::  Passed:                                                    :::
':::       flnm        => Filespec of file to read               :::
':::       width       => width of image                         :::
':::       height      => height of image                        :::
':::       depth       => color depth (in number of colors)      :::
':::       strImageType=> type of image (e.g. GIF, BMP, etc.)    :::
':::                                                             :::
':::::::::::::::::::::::::::::::::::::::::::::::::  ::::::::::::::::::
function gfxSpex(flnm, width, height, depth, strImageType)
       dim strPNG 
       dim strGIF
       dim strBMP
       dim strType
       dim strBuff
       dim lngSize
       dim flgFound
       dim strTarget
       dim lngPos
       dim ExitLoop
       dim lngMarkerSize

       strType = ""
       strImageType = "(unknown)"

       gfxSpex = False

       strPNG = chr(137) & chr(80) & chr(78)
       strGIF = "GIF"
       strBMP = chr(66) & chr(77)

       strType = GetBytes(flnm, 0, 3)

       if strType = strGIF then                                ' is GIF
               strImageType = "GIF"
               Width = lngConvert(GetBytes(flnm, 7, 2))
               Height = lngConvert(GetBytes(flnm, 9, 2))
               Depth = 2 ^ ((asc(GetBytes(flnm, 11, 1)) and 7) + 1)
               gfxSpex = True
       elseif left(strType, 2) = strBMP then           ' is BMP
               strImageType = "BMP"
               Width = lngConvert(GetBytes(flnm, 19, 2))
               Height = lngConvert(GetBytes(flnm, 23, 2))
               Depth = 2 ^ (asc(GetBytes(flnm, 29, 1)))
               gfxSpex = True
       elseif strType = strPNG then                    ' Is PNG
               strImageType = "PNG"
               Width = lngConvert2(GetBytes(flnm, 19, 2))
               Height = lngConvert2(GetBytes(flnm, 23, 2))
               Depth = getBytes(flnm, 25, 2)
               select case asc(right(Depth,1))
                       case 0
                               Depth = 2 ^ (asc(left(Depth, 1)))
                               gfxSpex = True
                       case 2
                               Depth = 2 ^ (asc(left(Depth, 1)) * 3)
                               gfxSpex = True
                       case 3
                               Depth = 2 ^ (asc(left(Depth, 1)))  '8
                               gfxSpex = True
                       case 4
                               Depth = 2 ^ (asc(left(Depth, 1)) * 2)
                               gfxSpex = True
                       case 6
                               Depth = 2 ^ (asc(left(Depth, 1)) * 4)
                               gfxSpex = True
                       case else
                               Depth = -1
               end select
       else
               strBuff = GetBytes(flnm, 0, -1)         ' Get all bytes from file
               lngSize = len(strBuff)
               flgFound = 0

               strTarget = chr(255) & chr(216) & chr(255)
               flgFound = instr(strBuff, strTarget)

               if flgFound = 0 then
                       exit function
               end if

               strImageType = "JPG"
               lngPos = flgFound + 2
               ExitLoop = false

               do while ExitLoop = False and lngPos < lngSize
                       do while asc(mid(strBuff, lngPos, 1)) = 255 and lngPos < lngSize
                               lngPos = lngPos + 1
                       loop

                       if asc(mid(strBuff, lngPos, 1)) < 192 or asc(mid(strBuff, lngPos, 1)) > 195 then
                               lngMarkerSize = lngConvert2(mid(strBuff, lngPos + 1, 2))
                               lngPos = lngPos + lngMarkerSize  + 1
                       else
                               ExitLoop = True
                       end if
               loop

               if ExitLoop = False then
                       Width = -1
                       Height = -1
                       Depth = -1
               else
                       Height = lngConvert2(mid(strBuff, lngPos + 4, 2))
                       Width = lngConvert2(mid(strBuff, lngPos + 6, 2))
                       Depth = 2 ^ (asc(mid(strBuff, lngPos + 8, 1)) * 8)
                       gfxSpex = True
               end if
       end if
End Function
%>
<html>
<head>
<title>Get Image Dimensions</title>
</head>
<body>
<%
If address<>"" Then
       Call CalcImageDimensions()
End If
%>
<form>
       Enter url address: <input name="image" value="<%=Request("image")%>" /><br />
       <button type="submit">Calculate</button>
</form>
</body>
</html>

[delgisa 0]

Valeu xanburzum, vou fazer os testes.

 

 

Depois eu posto aqui o resultado

 

 

 

Abraços

 

 

 

Jardel Paes

[delgisa 0]

Olá xanburzum,

 

Acabei de implementar o código acima e obitve o seguinte resultado:

image file size: 41952 (bytes)

image width: 349 (pixels)

image height: -15448 (pixels)

color depth: 256

image type: GIF

 

Agora, desculpe minha ignorância, mas em que estes dados será útil para mim?

Como devo aproveitá-los

 

Como implemento em meu código de upload?

 

Como ficaria essa imagem acima, se o lugar que ela será exibida no meu site está configurado para 300x250?

 

Desculpe, rsrsssr

 

 

 

Abraços

 

 

 

Jardel