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

Материал из 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


См. также[править | править код]