Качественно уменьшить изображение
Материал из DRKB
Как сделать 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