Качественно уменьшить изображение

== Как сделать Thumbnails? ==
Алгоритм качественного Resize'a, если точнее, то уменьшения
procedure MakeThumbNail(const Src, Dest: TBitmap);
type
 PRGB24 = ^TRGB24;
 TRGB24 = packed record
 B: Byte;
 G: Byte;
 R: Byte;
 end;
var
 x, y, ix, iy: Integer;
 x1, x2, x3: Integer;
 xscale, yscale: Single;
 iRed, iGrn, iBlu, iRatio: Longword;
 p, c1, c2, c3, c4, c5: TRGB24;
 pt, pt1: PRGB24;
 iSrc, iDst, s1: Integer;
 i, j, r, g, b, tmpY: Integer;
 RowDest, RowSource, RowSourceStart: Integer;
 w, h: Integer;
 dxmin, dymin: Integer;
 ny1, ny2, ny3: Integer;
 dx, dy: Integer;
 lutX, lutY: array of Integer;
begin
 if Src.PixelFormat <> pf24bit then Src.PixelFormat := pf24bit;
 if Dest.PixelFormat <> pf24bit then Dest.PixelFormat := pf24bit;
 w := Dest.Width;
 h := Dest.Height;
 if (Src.Width <= Dest.Width) and (Src.Height <= Dest.Height) then
 begin
 Dest.Assign(src);
 exit;
 end;
 iDst := (w * 24 + 31) and not 31;
 iDst := iDst div 8; // BytesPerScanline
 iSrc := (Src.Width * 24 + 31) and not 31;
 iSrc := iSrc div 8;
 xscale := 1 / (w / Src.Width);
 yscale := 1 / (h / Src.Height);
 // X lookup table
 SetLength(lutX, w);
 x1 := 0;
 x2 := Trunc(xscale);
 for x := 0 to w - 1 do
 begin
 lutX[x] := x2 - x1;
 x1 := x2;
 x2 := Trunc((x + 2) * xscale);
 end;
 // Y lookup table
 SetLength(lutY, h);
 x1 := 0;
 x2 := Trunc(yscale);
 for x := 0 to h - 1 do
 begin
 lutY[x] := x2 - x1;
 x1 := x2;
 x2 := Trunc((x + 2) * yscale);
 end;
 Dec(w);
 Dec(h);
 RowDest := Integer(Dest.Scanline[0]);
 RowSourceStart := Integer(Src.Scanline[0]);
 RowSource := RowSourceStart;
 for y := 0 to h do
 begin
 dy := lutY[y];
 x1 := 0;
 x3 := 0;
 for x := 0 to w do
 begin
 dx:= lutX[x];
 iRed:= 0;
 iGrn:= 0;
 iBlu:= 0;
 RowSource := RowSourceStart;
 for iy := 1 to dy do
 begin
 pt := PRGB24(RowSource + x1);
 for ix := 1 to dx do
 begin
 iRed := iRed + pt.R;
 iGrn := iGrn + pt.G;
 iBlu := iBlu + pt.B;
 Inc(pt);
 end;
 RowSource := RowSource - iSrc;
 end;
 iRatio := 65535 div (dx * dy);
 pt1 := PRGB24(RowDest + x3);
 pt1.R := (iRed * iRatio) shr 16;
 pt1.G := (iGrn * iRatio) shr 16;
 pt1.B := (iBlu * iRatio) shr 16;
 x1 := x1 + 3 * dx;
 Inc(x3, 3);
 end;
 RowDest := RowDest - iDst;
 RowSourceStart := RowSource;
 end;
 if dest.Height < 3 then exit;
 // Sharpening...
 s1 := Integer(Dest.ScanLine[0]);
 iDst := Integer(Dest.ScanLine[1]) - s1;
 ny1 := Integer(s1);
 ny2 := ny1 + iDst;
 ny3 := ny2 + iDst;
 for y := 1 to Dest.Height - 2 do
 begin
 for x := 0 to Dest.Width - 3 do
 begin
 x1 := x * 3;
 x2 := x1 + 3;
 x3 := x1 + 6;
 c1 := PRGB24(ny1 + x1)^;
 c2 := PRGB24(ny1 + x3)^;
 c3 := PRGB24(ny2 + x2)^;
 c4 := PRGB24(ny3 + x1)^;
 c5 := PRGB24(ny3 + x3)^;
 r := (c1.R + c2.R + (c3.R * -12) + c4.R + c5.R) div -8;
 g := (c1.G + c2.G + (c3.G * -12) + c4.G + c5.G) div -8;
 b := (c1.B + c2.B + (c3.B * -12) + c4.B + c5.B) div -8;
 if r < 0 then r := 0 else if r > 255 then r := 255;
 if g < 0 then g := 0 else if g > 255 then g := 255;
 if b < 0 then b := 0 else if b > 255 then b := 255;
 pt1 := PRGB24(ny2 + x2);
 pt1.R := r;
 pt1.G := g;
 pt1.B := b;
 end;
 Inc(ny1, iDst);
 Inc(ny2, iDst);
 Inc(ny3, iDst);
 end;
end;
Можно еще через StretchBlt, только перед ним надо задать
SetStretchBltMode(Canvas.Handle, HALFTONE);
Source: http://www.swissdelphicenter.ch/en/tipsindex.php
ID: 03826
----
== Уменьшение в 4 раза ==
В Delphi изменять размеры изображения очень просто, используя CopyRect:
procedure TForm1.Button1Click(Sender: TObject);
begin
 Form1.Canvas.Font.Size := 24;
 Form1.Canvas.TextOut(0, 0, 'Text');
 Form1.Canvas.CopyRect(Bounds(0, 50, 25, 10), Form1.Canvas,
 Bounds(0, 0, 100, 40));
end;
Но этот способ не очень хорош для уменьшения не маленьких картинок - мелкие детали сливаются. Для частичного устранения этого недостатка при уменьшении изображения в четыре раза я беру средний цвет в каждом квадратике 4X4. К чему это приводит, посмотрите сами.
procedure TForm1.Button1Click(Sender: TObject);
var
 x, y: Integer;
 i, j: Integer;
 r, g, b: Integer;
begin
 Form1.Canvas.Font.Size := 24;
 Form1.Canvas.TextOut(0, 0, 'Text');
 for y := 0 to 10 do
 begin
 for x := 0 to 25 do
 begin
 r := 0;
 for i := 0 to 3 do
 for j := 0 to 3 do
 r := r + GetRValue(Form1.Canvas.Pixels[4*x+i, 4*y+j]);
 r := Round(r / 16);
 g := 0;
 for i := 0 to 3 do
 for j := 0 to 3 do
 g := g + GetGValue(Form1.Canvas.Pixels[4*x+i, 4*y+j]);
 g := Round(g / 16);
 b := 0;
 for i := 0 to 3 do
 for j := 0 to 3 do
 b := b + GetBValue(Form1.Canvas.Pixels[4*x+i, 4*y+j]);
 b := Round(b / 16);
 Form1.Canvas.Pixels[x, y+50] := RGB(r, g, b)
 end;
 Application.ProcessMessages;
 end;
end;
ID: 03829
----
== Из уже созданной картинки Big заполняет уже созданную картинку Small ==
// Из уже созданной картинки Big заполняет уже созданную картинку Small
procedure ShrinkPic(Big: TBitmap; Small: TBitmap; XScale: Integer = 0; YScale: Integer = 0);
var
 x, y: Integer;
 i, j: Integer;
 r, g, b: Integer;
begin
 // Если указан фактор сжатия по ширине, то устанавливаем правильный размер, иначе вычисляем фактор
 if XScale = 0 then
 XScale := Big.Width div Small.Width
 else
 Small.Width := Big.Width div XScale;
 // Если указан фактор сжатия по высоте, то устанавливаем правильный размер, иначе вычисляем фактор
 if YScale = 0 then
 YScale := Big.Height div Small.Height
 else
 Small.Height := Big.Height div YScale;
 for y := 0 to Small.Height-1 do
 begin
 for x := 0 to Small.Width-1 do
 begin
 r := 0;
 g := 0;
 b := 0;
 for i := 0 to XScale-1 do
 begin
 for j := 0 to YScale-1 do
 begin
 r := r + GetRValue(Big.Canvas.Pixels[XScale*x+i, YScale*y+j]);
 g := g + GetGValue(Big.Canvas.Pixels[XScale*x+i, YScale*y+j]);
 b := b + GetBValue(Big.Canvas.Pixels[XScale*x+i, YScale*y+j]);
 end;
 end;
 r := Round(r / XScale / YScale);
 g := Round(g / XScale / YScale);
 b := Round(b / XScale / YScale);
 Small.Canvas.Pixels[x, y] := RGB(r, g, b);
 end;
 end;
end;
Замечания.
:1. В двух вложенных форах можно xscale-1 или yscale-1 заменить константой, в зависимости от области использования. Мой пример соптимизирован для соотношения 4:1.
:2. Процедура медленная. Даже использование scanline'ов не спасает ситуацию кардинально, поэтому я не стал приводить более быстродействующий вариант, так как он более запутан. Для продвинутого преобразования я использую отдельную библиотеку. 
Author: December
Source: Vingrad.ru http://forum.vingrad.ru
ID: 03831
== См. также ==
* How to scale bitmap by percent?
* Изменение размера
* Растягивание изображения
* Масштабирование для Canvas
* Создание уменьшенной копии картинки
* Качественное увеличение изображения билинейной интерполяцией
Category:Графика
Category:Bitmap