Buscar

Diminuir Bitmaps sem perder qualidade da imagem

Código

procedure QualityResizeBitmap(bmpOrig, bmpDest: TBitmap; newWidth, newHeight: Integer);
var
   xIni, xFin, yIni, yFin, xSalt, ySalt: Double;
   X, Y, pX, pY, tpX: Integer;
   R, G, B: Integer;
   pxColor: TColor;
begin
   bmpDest.Width  := newWidth;
   bmpDest.Height := newHeight;

   xSalt := bmpOrig.Width / newWidth;
   ySalt := bmpOrig.Height / newHeight;

   yFin := 0;
   for Y := 0 to pred(newHeight) do
   begin
      yIni := yFin;
      yFin := yIni + ySalt;
      if yFin >= bmpOrig.Height then
         yFin := pred(bmpOrig.Height);

      xFin := 0;
      for X := 0 to pred(newWidth) do
      begin
         xIni := xFin;
         xFin := xIni + xSalt;
         if xFin >= bmpOrig.Width then
            xFin := pred(bmpOrig.Width);

         R := 0;
         G := 0;
         B := 0;
         tpX := 0;

         for pY := Round(yIni) to Round(yFin) do
            for pX := Round(xIni) to Round(xFin) do
            begin
               Inc(tpX);
               pxColor := ColorToRGB(bmpOrig.Canvas.Pixels[pX, pY]);
               R := R + GetRValue(pxColor);
               G := G + GetGValue(pxColor);
               B := B + GetBValue(pxColor);
            end;

         bmpDest.Canvas.Pixels[X,Y] := RGB(Round(R/tpX),Round(G/tpX),Round(B/tpX));
      end;
   end;
end;

{
para chamar:
QualityResizeBitmap(Image1.Picture.Bitmap,Image2.Picture.Bitmap,Image2.Width,Image2.Height);

Onde Image1 é um TImage que possui um Bitmap grande com qualidade alta e Image2 é um TImage menor.
}

Publicidade

Vote na dica




Quantidade de votos: 2 votos
Aceitação: 20%


Detalhes da dica

Categoria: Object pascal
Adicionada dia: 24/06/09
Por: Fábio Romão De Oliveira
Visualizada: 9197 vezes

Planeta Delphi - Tudo sobre programação Delphi Planeta Delphi - www.planetadelphi.com.br - Todos os direitos reservados | Copyright 2001-2009