como redimensionar imagem?

Delphi

08/02/2005

Olá

gostaria de redimensionar uma imagem antes de grava-la num banco... de forma que todas as imagens entrem num tamanho padrão...
lembrando que o objetivo é evitar que imagem com tamanho grande seja salvas e ocupem muito espaço!
como posso fazer?

obrigado...


Mrcdlf

Mrcdlf

Curtidas 0

Respostas

Ivanh

Ivanh

08/02/2005

Ja usou [b:89e5778cc9]BitBlt[/b:89e5778cc9]????

Na revista 58, tem um artigo sobre criação de jogos, talvez ajude...


GOSTEI 0
Marcelo Saviski

Marcelo Saviski

08/02/2005

De uma pesquisada sobre isso aqui no fórum mesmo, deve ter exemplos de uns 10 tipos diferentes de fazer isso


GOSTEI 0
Mrcdlf

Mrcdlf

08/02/2005

[quote:306904066c=´Marcelo Saviski´]De uma pesquisada sobre isso aqui no fórum mesmo, deve ter exemplos de uns 10 tipos diferentes de fazer isso[/quote:306904066c]


pelo q pesquisei o BitBlt não faz esse tipo de coisa... pelo q entendi ele só copia a imagem como ela é...
se eu estiver errado, por favor, me corrijam

agora achei um exemplo sim, só q ele deixa a imagem numa qualidade muito ruim será q é possivel melhorar isso?

o codigo q usei foi o seguinte:

Código:
function PadronizaTamanho(Imagem: TGraphic; W, H: Integer; Tipo: TGraphicClass = nil): TGraphic;
var
B: TBitmap;
begin
B := TBitmap.Create;
try
B.Width := W;
B.Height := H;
B.Canvas.StretchDraw(Rect(0, 0, W, H), Imagem);
if Tipo = nil then
Result := TGraphic(Imagem.ClassType.Create)
else
Result := Tipo.Create;
Result.Assign(B);
finally
B.Free;
end;
end;


Exemplo de uso:
Código:
procedure TForm1.Button1Click(Sender: TObject);
var
Nova: TGraphic;
begin
Nova := PadronizaTamanho(Image1.Picture.Graphic, 80, 80, TJPEGImage);
try
Image2.Picture.Graphic := Nova;
finally
Nova.Free;
end;
end;


GOSTEI 0
Marcelo Saviski

Marcelo Saviski

08/02/2005

Fica meio matado mesmo, como vc ta diminuindo de tamanho, ele pula algumas linhas para diminuir de tamanho e a imagem fica falhada

tem como melhorar sim, se vc tiver a jcl (JEDI Code Library), pode usar essa unit: http://www.koders.com/delphi/fid1DF4D91A23AF9688471FA339A4E276A44C33099A.aspx

ou a GR32 (Graphics32), que tem várias funções para isso, (DoStretch) http://www.koders.com/delphi/fid683F1F4625F55765FD95866D982B69D65D332E78.aspx

tem só essa função DoStrech, um pouco alterada aqui: http://www.experts-exchange.com/Programming/Programming_Languages/Delphi/Q_10211552.html

e tem esse exemplo que peguei na net um vez, mas não lembro aonde:


{ 

  Before importing an image (jpg) into a database, 
  I would like to resize it (reduce its size) and 
  generate the corresponding smaller file. How can I do this? 


  Load the JPEG into a bitmap, create a new bitmap 
  of the size that you want and pass them both into 
  SmoothResize then save it again ... 
  there´s a neat routine JPEGDimensions that 
  gets the JPEG dimensions without actually loading the JPEG into a bitmap, 
  saves loads of time if you only need to test its size before resizing. 
} 



uses 
  JPEG; 

type 
  TRGBArray = array[Word] of TRGBTriple; 
  pRGBArray = ^TRGBArray; 

{--------------------------------------------------------------------------- 
-----------------------} 

procedure SmoothResize(Src, Dst: TBitmap); 
var 
  x, y: Integer; 
  xP, yP: Integer; 
  xP2, yP2: Integer; 
  SrcLine1, SrcLine2: pRGBArray; 
  t3: Integer; 
  z, z2, iz2: Integer; 
  DstLine: pRGBArray; 
  DstGap: Integer; 
  w1, w2, w3, w4: Integer; 
begin 
  Src.PixelFormat := pf24Bit; 
  Dst.PixelFormat := pf24Bit; 

  if (Src.Width = Dst.Width) and (Src.Height = Dst.Height) then 
    Dst.Assign(Src) 
  else 
  begin 
    DstLine := Dst.ScanLine[0]; 
    DstGap  := Integer(Dst.ScanLine[1]) - Integer(DstLine); 

    xP2 := MulDiv(pred(Src.Width), $10000, Dst.Width); 
    yP2 := MulDiv(pred(Src.Height), $10000, Dst.Height); 
    yP  := 0; 

    for y := 0 to pred(Dst.Height) do 
    begin 
      xP := 0; 

      SrcLine1 := Src.ScanLine[yP shr 16]; 

      if (yP shr 16 < pred(Src.Height)) then 
        SrcLine2 := Src.ScanLine[succ(yP shr 16)] 
      else 
        SrcLine2 := Src.ScanLine[yP shr 16]; 

      z2  := succ(yP and $FFFF); 
      iz2 := succ((not yp) and $FFFF); 
      for x := 0 to pred(Dst.Width) do 
      begin 
        t3 := xP shr 16; 
        z  := xP and $FFFF; 
        w2 := MulDiv(z, iz2, $10000); 
        w1 := iz2 - w2; 
        w4 := MulDiv(z, z2, $10000); 
        w3 := z2 - w4; 
        DstLine[x].rgbtRed := (SrcLine1[t3].rgbtRed * w1 + 
          SrcLine1[t3 + 1].rgbtRed * w2 + 
          SrcLine2[t3].rgbtRed * w3 + SrcLine2[t3 + 1].rgbtRed * w4) shr 16; 
        DstLine[x].rgbtGreen := 
          (SrcLine1[t3].rgbtGreen * w1 + SrcLine1[t3 + 1].rgbtGreen * w2 + 

          SrcLine2[t3].rgbtGreen * w3 + SrcLine2[t3 + 1].rgbtGreen * w4) shr 16; 
        DstLine[x].rgbtBlue := (SrcLine1[t3].rgbtBlue * w1 + 
          SrcLine1[t3 + 1].rgbtBlue * w2 + 
          SrcLine2[t3].rgbtBlue * w3 + 
          SrcLine2[t3 + 1].rgbtBlue * w4) shr 16; 
        Inc(xP, xP2); 
      end;  
      Inc(yP, yP2); 
      DstLine := pRGBArray(Integer(DstLine) + DstGap); 
    end;  
  end;  
end;  

{--------------------------------------------------------------------------- 
-----------------------} 

function LoadJPEGPictureFile(Bitmap: TBitmap; FilePath, FileName: string): Boolean; 
var 
  JPEGImage: TJPEGImage; 
begin 
  if (FileName = ´´) then    // No FileName so nothing 
    Result := False  //to load - return False... 
  else 
  begin 
    try  // Start of try except 
      JPEGImage := TJPEGImage.Create;  // Create the JPEG image... try  // now 
      try  // to load the file but 
        JPEGImage.LoadFromFile(FilePath + FileName); 
        // might fail...with an Exception. 
        Bitmap.Assign(JPEGImage); 
        // Assign the image to our bitmap.Result := True; 
        // Got it so return True. 
      finally 
        JPEGImage.Free;  // ...must get rid of the JPEG image. finally 
      end;  
    except 
      Result := False; // Oops...never Loaded, so return False. 
    end;  
  end;  
end;  


{--------------------------------------------------------------------------- 
-----------------------} 


function SaveJPEGPictureFile(Bitmap: TBitmap; FilePath, FileName: string; 
  Quality: Integer): Boolean; 
begin 
  Result := True; 
  try 
    if ForceDirectories(FilePath) then 
    begin 
      with TJPegImage.Create do 
      begin 
        try 
          Assign(Bitmap); 
          CompressionQuality := Quality; 
          SaveToFile(FilePath + FileName); 
        finally 
          Free; 
        end;  
      end;  
    end;  
  except 
    raise; 
    Result := False; 
  end;  
end;  


{--------------------------------------------------------------------------- 
-----------------------} 


procedure ResizeImage(FileName: string; MaxWidth: Integer); 
var 
  OldBitmap: TBitmap; 
  NewBitmap: TBitmap; 
  aWidth: Integer; 
begin 
  OldBitmap := TBitmap.Create; 
  try 
    if LoadJPEGPictureFile(OldBitmap, ExtractFilePath(FileName), 
      ExtractFileName(FileName)) then 
    begin 
      aWidth := OldBitmap.Width; 
      if (OldBitmap.Width > MaxWidth) then 
      begin 
        aWidth    := MaxWidth; 
        NewBitmap := TBitmap.Create; 
        try 
          NewBitmap.Width  := MaxWidth; 
          NewBitmap.Height := MulDiv(MaxWidth, OldBitmap.Height, OldBitmap.Width); 
          SmoothResize(OldBitmap, NewBitmap); 
          RenameFile(FileName, ChangeFileExt(FileName, ´.$$$´)); 
          if SaveJPEGPictureFile(NewBitmap, ExtractFilePath(FileName), 
            ExtractFileName(FileName), 75) then 
            DeleteFile(ChangeFileExt(FileName, ´.$$$´)) 
          else 
            RenameFile(ChangeFileExt(FileName, ´.$$$´), FileName); 
        finally 
          NewBitmap.Free; 
        end;  
      end;  
    end;  
  finally 
    OldBitmap.Free; 
  end;  
end; 


{--------------------------------------------------------------------------- 
-----------------------} 

function JPEGDimensions(Filename : string; var X, Y : Word) : boolean; 
var 
  SegmentPos : Integer; 
  SOIcount : Integer; 
  b : byte; 
begin 
  Result  := False; 
  with TFileStream.Create(Filename, fmOpenRead or fmShareDenyNone) do 
  begin 
    try 
      Position := 0; 
      Read(X, 2); 
      if (X <> $D8FF) then 
        exit; 
      SOIcount  := 0; 
      Position  := 0; 
      while (Position + 7 < Size) do 
      begin 
        Read(b, 1); 
        if (b = $FF) then begin 
          Read(b, 1); 
          if (b = $D8) then 
            inc(SOIcount); 
          if (b = $DA) then 
            break; 
        end;  
      end;  
      if (b <> $DA) then 
        exit; 
      SegmentPos  := -1; 
      Position    := 0; 
      while (Position + 7 < Size) do 
      begin 
        Read(b, 1); 
        if (b = $FF) then 
        begin 
          Read(b, 1); 
          if (b in [$C0, $C1, $C2]) then 
          begin 
            SegmentPos  := Position; 
            dec(SOIcount); 
            if (SOIcount = 0) then 
              break; 
          end;  
        end;  
      end;  
      if (SegmentPos = -1) then 
        exit; 
      if (Position + 7 > Size) then 
        exit; 
      Position := SegmentPos + 3; 
      Read(Y, 2); 
      Read(X, 2); 
      X := Swap(X); 
      Y := Swap(Y); 
      Result  := true; 
    finally 
      Free; 
    end;  
  end;  
end;


vc usaria essas funções no lugar do BitBtl, ou StretchDraw para ter maois qualidade no redimencionamento

Ainda tem mais estes dois exemplos:

http://www.swissdelphicenter.ch/en/showcode.php?id=1896
http://www.swissdelphicenter.ch/en/showcode.php?id=1463


GOSTEI 0
Pistesil

Pistesil

08/02/2005

e tem esse exemplo que peguei na net um vez, mas não lembro aonde:

Eu uso essa funcao e ela funcionou perfeitamente para mim..


GOSTEI 0
Mrcdlf

Mrcdlf

08/02/2005

[quote:1018c0d141]e tem esse exemplo que peguei na net um vez, mas não lembro aonde:

Eu uso essa funcao e ela funcionou perfeitamente para mim..[/quote:1018c0d141]

por incrivel que pareça essa função não funcionou... a qualidade continou ruim...

mais teve um link q tem uma função que funciono perfeitamente... apersar de aki tersido um pouco lenta...

a função está abaixo para facilitar...

valeu ai pela ajuda!!!!

procedure TFormConvertir.ResizeBitmap(imgo, imgd: TBitmap; nw, nh: Integer);
var
xini, xfi, yini, yfi, saltx, salty: single;
x, y, px, py, tpix: integer;
PixelColor: TColor;
r, g, b: longint;

function MyRound(const X: Double): Integer;
begin
Result := Trunc(x);
if Frac(x) >= 0.5 then
if x >= 0 then Result := Result + 1
else
Result := Result - 1;
// Result := Trunc(X + (-2 * Ord(X < 0) + 1) * 0.5);
end;

begin
// Set target size

imgd.Width := nw;
imgd.Height := nh;

// Calcs width & height of every area of pixels of the source bitmap

saltx := imgo.Width / nw;
salty := imgo.Height / nh;


yfi := 0;
for y := 0 to nh - 1 do
begin
// Set the initial and final Y coordinate of a pixel area

yini := yfi;
yfi := yini + salty;
if yfi >= imgo.Height then yfi := imgo.Height - 1;

xfi := 0;
for x := 0 to nw - 1 do
begin
// Set the inital and final X coordinate of a pixel area

xini := xfi;
xfi := xini + saltx;
if xfi >= imgo.Width then xfi := imgo.Width - 1;


// This loop calcs del average result color of a pixel area
// of the imaginary grid

r := 0;
g := 0;
b := 0;
tpix := 0;

for py := MyRound(yini) to MyRound(yfi) do
begin
for px := MyRound(xini) to MyRound(xfi) do
begin
Inc(tpix);
PixelColor := ColorToRGB(imgo.Canvas.Pixels[px, py]);
r := r + GetRValue(PixelColor);
g := g + GetGValue(PixelColor);
b := b + GetBValue(PixelColor);
end;
end;

// Draws the result pixel

imgd.Canvas.Pixels[x, y] :=
rgb(MyRound(r / tpix),
MyRound(g / tpix),
MyRound(b / tpix)
);
end;
end;
end;


GOSTEI 0
Beppe

Beppe

08/02/2005

Esta função toma uma média dos pixels vizinhos, obviamente um resultado melhor. De noite verei o que posso fazer no quesito eficiência.

PS: A primeira função eu que escrevi e funciona muito bem para fotografias. btw, quem faz o serviço bruto é o Delphi/Windows.


GOSTEI 0
Mrcdlf

Mrcdlf

08/02/2005

Esta função toma uma média dos pixels vizinhos, obviamente um resultado melhor. De noite verei o que posso fazer no quesito eficiência. PS: A primeira função eu que escrevi e funciona muito bem para fotografias. btw, quem faz o serviço bruto é o Delphi/Windows.


a primeira função aki simplesmente não teve resultado nenhum...
pode ser que eu tenha feito algo de errado...


GOSTEI 0
Beppe

Beppe

08/02/2005

a primeira função aki simplesmente não teve resultado nenhum... pode ser que eu tenha feito algo de errado...

:shock:

Fala de PadronizaTamanho? Tanto pra mim, como o desenvolvedor que pediu a função, deu certo...


GOSTEI 0
Mrcdlf

Mrcdlf

08/02/2005

[quote:fe7164278c=´mrcdlf´]a primeira função aki simplesmente não teve resultado nenhum... pode ser que eu tenha feito algo de errado...

:shock:

Fala de PadronizaTamanho? Tanto pra mim, como o desenvolvedor que pediu a função, deu certo...[/quote:fe7164278c]


funcionar funciono só q a qualidade continuou ruim...
bem de qualquer forma eu posso ter feito algo de errado tb!
mais a função que falei funcionou perfeitamente...

valeu!


GOSTEI 0
Beppe

Beppe

08/02/2005

Vc pode me mandar uma imagem que não deu um bom resultado com PadronizaImagem?

Pode hospedar no ImageShack.us ou me mandar por e-mail.

T+


GOSTEI 0
Beppe

Beppe

08/02/2005

Agora achei um imagem que gera um resultado inferior, mas eu não diria ruim...

procedure ResizeBitmap32(imgo, imgd: TBitmap; nw, nh: Integer);
var
  xini, xfi, yini, yfi, saltx, salty: single;
  x, y, px, py, tpix: integer;
  PixelColor: TColor;
  r, g, b: longint;
  P1, P2: PChar;
begin
// Set target size

  imgd.Width := nw;
  imgd.Height := nh;

  P1 := imgo.ScanLine[imgo.Height - 1];
  P2 := imgd.ScanLine[imgd.Height - 1];

// Calcs width & height of every area of pixels of the source bitmap

  saltx := imgo.Width / nw;
  salty := imgo.Height / nh;


  yfi := 0;
  for y := 0 to nh - 1 do
  begin
// Set the initial and final Y coordinate of a pixel area

    yini := yfi;
    yfi := yini + salty;
    if yfi >= imgo.Height then yfi := imgo.Height - 1;

    xfi := 0;
    for x := 0 to nw - 1 do
    begin
// Set the inital and final X coordinate of a pixel area

      xini := xfi;
      xfi := xini + saltx;
      if xfi >= imgo.Width then xfi := imgo.Width - 1;


// This loop calcs del average result color of a pixel area
// of the imaginary grid

      r := 0;
      g := 0;
      b := 0;
      tpix := 0;

      for py := Round(yini) to Round(yfi) do
      begin
        for px := Round(xini) to Round(xfi) do
        begin
          Inc(tpix);
          PixelColor := (PColor(P1 + ((imgo.Height - py - 1) * imgo.Width + px)*4)^);
          r := r + PixelColor shr 16 and $ff;
          g := g + PixelColor shr 08 and $ff;
          b := b + PixelColor shr 00 and $ff;
        end;
      end;

// Draws the result pixel

//      PColor(P2 + ((imgd.Height - y - 1) * imgd.Width + x)*4)^ := rgb(Round(r / tpix),Round(g / tpix),Round(b / tpix));
      imgd.Canvas.Pixels[x, y] := rgb((r div tpix),(g div tpix),(b div tpix));
    end;
  end;
end;


Reescrevi umas partes da rotina, ficou bem melhor, embora eu pudesse fazer ainda melhor.


GOSTEI 0
Mrcdlf

Mrcdlf

08/02/2005

Vc pode me mandar uma imagem que não deu um bom resultado com PadronizaImagem? Pode hospedar no ImageShack.us ou me mandar por e-mail. T+


essa ultima função que vc me mandou está dando um erro aqui...
me fala seu e-mail que vou lhe mandar a imagem.


GOSTEI 0
Beppe

Beppe

08/02/2005

Desculpa cara, esqueci de citar...o bitmap precisa ser 32 bits.

Adiciona um SeuBitmap.PixelFormat := pf32bit;

Ou troque um *4 por *3 para 24bit. Não testei, mas pode funcionar.


GOSTEI 0
Mrcdlf

Mrcdlf

08/02/2005

Desculpa cara, esqueci de citar...o bitmap precisa ser 32 bits. Adiciona um SeuBitmap.PixelFormat := pf32bit; Ou troque um *4 por *3 para 24bit. Não testei, mas pode funcionar.


bem aqui ainda não resolveu o problema


GOSTEI 0
Beppe

Beppe

08/02/2005

Qual o erro que dá?


GOSTEI 0
Beppe

Beppe

08/02/2005

Vc pode usar isto por enquanto...o problema é no algoritmo original, que acessa pixels fora da imagem...estou pensando em reescrever do zero se eu tiver tempo.

procedure ResizeBitmap32(imgo, imgd: TBitmap; nw, nh: Integer);
var
  xini, xfi, yini, yfi, saltx, salty: single;
  x, y, px, py, tpix: integer;
  PixelColor: TColor;
  r, g, b: longint;
  P1, P2: PChar;
  pix: integer;
begin
// Set target size

  imgd.Width := nw;
  imgd.Height := nh;

  imgo.PixelFormat := pf32bit;
  imgd.PixelFormat := pf32bit;

  P1 := imgo.ScanLine[imgo.Height - 1];
  P2 := imgd.ScanLine[imgd.Height - 1];

// Calcs width & height of every area of pixels of the source bitmap

  saltx := imgo.Width / nw;
  salty := imgo.Height / nh;


  yfi := 0;
  for y := 0 to nh - 1 do
  begin
// Set the initial and final Y coordinate of a pixel area

    yini := yfi;
    yfi := yini + salty;
    if yfi >= imgo.Height then yfi := imgo.Height - 1;

    xfi := 0;
    for x := 0 to nw - 1 do
    begin
// Set the inital and final X coordinate of a pixel area

      xini := xfi;
      xfi := xini + saltx;
      if xfi >= imgo.Width then xfi := imgo.Width - 1;


// This loop calcs del average result color of a pixel area
// of the imaginary grid

      r := 0;
      g := 0;
      b := 0;
      tpix := 0;

      for py := Round(yini) to Round(yfi) do
      begin
        for px := Round(xini) to Round(xfi) do
        begin
          Inc(tpix);
          pix := (imgo.Height - py - 1) * imgo.Width + px;
          if pix < 0 then pix := px;
          PixelColor := (PColor(P1 + pix*4)^);
          r := r + PixelColor shr 16 and $ff;
          g := g + PixelColor shr 08 and $ff;
          b := b + PixelColor shr 00 and $ff;
        end;
      end;

// Draws the result pixel

      imgd.Canvas.Pixels[x, y] := rgb((r div tpix),(g div tpix),(b div tpix));
    end;
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  B1, B2: TBitmap;
begin
  B1 := TBitmap.Create;
  B1.Assign(Image1.Picture.Graphic);
  B2 := TBitmap.Create;
  B1.PixelFormat := pf32bit;
  B2.PixelFormat := pf32bit;
  ResizeBitmap32(B1, B2, 105, 105);
  Image2.Picture.Graphic := B2;
end;



GOSTEI 0
Beppe

Beppe

08/02/2005

Novo round! 8)

Removi cálculos com ponto flutuante, ficou mais rápido e não percebi diferença no resultado.

procedure ResizeBitmap32(imgo, imgd: TBitmap; nw, nh: Integer);
var
  xini, xfi, yini, yfi, saltx, salty: integer;
  x, y, px, py, tpix: integer;
  PixelColor: TColor;
  r, g, b: longint;
  P1, P2: PChar;
  pix: integer;
begin
// Set target size

  imgd.Width := nw;
  imgd.Height := nh;

  imgo.PixelFormat := pf32bit;
  imgd.PixelFormat := pf32bit;

  P1 := imgo.ScanLine[imgo.Height - 1];
  P2 := imgd.ScanLine[imgd.Height - 1];

// Calcs width & height of every area of pixels of the source bitmap

  saltx := imgo.Width div nw;
  salty := imgo.Height div nh;


  yfi := 0;
  for y := 0 to nh - 1 do
  begin
// Set the initial and final Y coordinate of a pixel area

    yini := yfi;
    yfi := yini + salty;
    if yfi >= imgo.Height then yfi := imgo.Height - 1;

    xfi := 0;
    for x := 0 to nw - 1 do
    begin
// Set the inital and final X coordinate of a pixel area

      xini := xfi;
      xfi := xini + saltx;
      if xfi >= imgo.Width then xfi := imgo.Width - 1;


// This loop calcs del average result color of a pixel area
// of the imaginary grid

      r := 0;
      g := 0;
      b := 0;
      tpix := 0;

      for py := yini to yfi do
      begin
        for px := xini to xfi do
        begin
          Inc(tpix);
          pix := (imgo.Height - py - 1) * imgo.Width + px;
          PixelColor := (PColor(P1 + pix*4)^);
          r := r + PixelColor shr 16 and $ff;
          g := g + PixelColor shr 08 and $ff;
          b := b + PixelColor shr 00 and $ff;
        end;
      end;

// Draws the result pixel

//      imgd.Canvas.Pixels[x, y] := rgb((r div tpix),(g div tpix),(b div tpix));
      pix := (imgd.Height - y - 1) * imgd.Width + x;
      PColor(P2 + pix*4)^ := rgb((r div tpix),(g div tpix),(b div tpix));
    end;
  end;
end;


Qual sua versão do Dephi?


GOSTEI 0
Mrcdlf

Mrcdlf

08/02/2005

Novo round! 8) Removi cálculos com ponto flutuante, ficou mais rápido e não percebi diferença no resultado. Qual sua versão do Dephi?


agora sim, realmente não teve diferença e ficou bem mais rapido!!!!
muito bom!

bem estou usando o Delphi 6

valeu mesmo pela força!


GOSTEI 0
Beppe

Beppe

08/02/2005

Perguntei pq no Delphi 5 não há como usar MMX(só se eu digitasse o código de máquina diretamente).

Agora não tenho tempo para isso, mas tenho planos de implementar operações em gráficos em assembly. Já tenho algumas prontas e resultado ficou muito bom.

T+


GOSTEI 0
POSTAR