Resize a TBitmap quickly

Problem/Question/Abstract:

I would like to resize this bitmap (720 x 416), but really rapidly ( I must do 25 images/second). Could you tell me how I can do that ?

Answer:

Solve 1:

This routine using TBitmap.Scanline was able to do the job in 0.25 seconds, on my celeron 466:

procedure Squash(bmpS, bmpD: TBitmap);
var
  scanlS, scanlD: Pointer;
  widthS, widthD: integer;
  yS, sInc, yD: integer;
begin
  {assume correct size for bitmaps and assume pixelformat of 24bpp
  for both. These could be precomputed but it wouldnt save much time}
  widthS := integer(bmpS.Scanline[1]) - integer(bmpS.Scanline[0]);
  widthD := integer(bmpD.Scanline[1]) - integer(bmpD.Scanline[0]);
  {how many scanlines to move down in source, per dest scanline}
  sInc := (bmpS.Height shl 16) div bmpD.Height;
  scanlS := bmpS.Scanline[0];
  scanlD := bmpD.Scanline[0];
  yS := 0;
  for yD := 0 to bmpD.Height - 1 do
  begin
    {copy scanline}
    Move(scanlS^, scanlD^, bmpD.Width * 3); {assumes pf24bit}
    inc(yS, sInc);
    {move down whole number of scanlines}
    inc(integer(scanlS), widthS * (yS shr 16));
    {and update yS to reflect the move}
    dec(yS, yS and $FFFF0000);
    inc(integer(scanlD), widthD);
  end;
end;


Solve 2:

Here's a procedure for fast resizing: it is for 24bit pixel format only.

procedure fastSmoothResize(var dst: TBitmap; NuWidth, NuHeight: integer);
var
  x, y, xP, yP, yP2, xP2: Integer;
  Read, Read2: PByteArray;
  t, z, z2, iz2: Integer;
  pc: PBytearray;
  w1, w2, w3, w4: Integer;
  Col1r, col1g, col1b, Col2r, col2g, col2b: byte;
  src: TBitmap;
begin
  src := TBitmap.create;
  src.pixelformat := pf24bit;
  {src.width := dst.width;
  src.height := dst.height;
  src.canvas.draw(0, 0, dst);}
  src.assign(dst);
  src.freeimage;
  dst.width := nuwidth;
  dst.height := nuheight;
  xP2 := ((src.Width - 1) shl 15) div Dst.Width;
  yP2 := ((src.Height - 1) shl 15) div Dst.Height;
  yP := 0;
  for y := 0 to Dst.Height - 1 do
  begin
    xP := 0;
    Read := src.ScanLine[yP shr 15];
    if yP shr 16 < src.Height - 1 then
      Read2 := src.ScanLine[yP shr 15 + 1]
    else
      Read2 := src.ScanLine[yP shr 15];
    pc := Dst.scanline[y];
    z2 := yP and $7FFF;
    iz2 := $8000 - z2;
    for x := 0 to Dst.Width - 1 do
    begin
      t := xP shr 15;
      Col1r := Read[t * 3];
      Col1g := Read[t * 3 + 1];
      Col1b := Read[t * 3 + 2];
      Col2r := Read2[t * 3];
      Col2g := Read2[t * 3 + 1];
      Col2b := Read2[t * 3 + 2];
      z := xP and $7FFF;
      w2 := (z * iz2) shr 15;
      w1 := iz2 - w2;
      w4 := (z * z2) shr 15;
      w3 := z2 - w4;
      pc[x * 3 + 2] := (Col1b * w1 + Read[(t + 1) * 3 + 2] * w2 + Col2b * w3 +
        Read2[(t + 1) * 3 + 2] * w4) shr 15;
      pc[x * 3 + 1] := (Col1g * w1 + Read[(t + 1) * 3 + 1] * w2 + Col2g * w3 +
        Read2[(t + 1) * 3 + 1] * w4) shr 15;
      pc[x * 3] := (Col1r * w1 + Read2[(t + 1) * 3] * w2 + Col2r * w3 + Read2[(t + 1) * 3] * w4) shr 15;
      Inc(xP, xP2);
    end;
    Inc(yP, yP2);
  end;
  src.free;
end;


Solve 3:

See the example below, which is a nice thumbnail generator and is quite fast, too. The src image is the original bitmap you want to downscale, dest is the bitmap to write the thumbnail into. Note: They must be 24 bit! Only downscaling is supported and only proportional.

procedure MakeThumbNail(src, dest: TBitmap);
type
  PRGB24 = ^TRGB24;
  TRGB24 = packed record
    B: Byte;
    G: Byte;
    R: Byte;
  end;
  TLine24 = array[0..MaxInt div SizeOf(TRGB24) - 1] of TRGB24;
  PLine24 = ^TLine24;
var
  xscale, yscale: double;
  destY, destX: Integer;
  x1, x2, y1, y2: Integer;
  ix, iy: Integer;
  new_red, new_green, new_blue: Integer;
  totalRed, totalGreen, totalBlue: double;
  ratio: double;
  p: trgb24;
  pt1: pRGB24;
  ptrD, ptrS: integer;
  s1, s3: PLine24;
  i, j, x, y, r, g, b: integer;
begin
  s1 := dest.ScanLine[0];
  ptrD := integer(dest.ScanLine[1]) - integer(s1);
  s3 := src.ScanLine[0];
  ptrS := integer(src.ScanLine[1]) - integer(s3);
  xscale := dest.Width / src.Width;
  yscale := dest.Height / src.Height;
  for y := 0 to dest.Height - 1 do
  begin
    y1 := Trunc(y / yscale);
    y2 := Trunc((y + 1) / yscale) - 1;
    for x := 0 to dest.Width - 1 do
    begin
      x1 := Trunc(x / xscale);
      x2 := Trunc((x + 1) / xscale) - 1;
      totalRed := 0;
      totalGreen := 0;
      totalBlue := 0;
      for iy := y1 to y2 do
        for ix := x1 to x2 do
        begin
          p := pRGB24(PtrS * iy + (ix * 3) + Integer(s3))^;
          totalRed := totalRed + p.R;
          totalGreen := totalGreen + p.G;
          totalBlue := totalBlue + p.B;
        end;
      ratio := 1 / (x2 - x1 + 1) / (y2 - y1 + 1);
      pt1 := pRGB24(PtrD * y + (x * 3) + Integer(s1));
      pt1.R := Round(totalRed * ratio);
      pt1.G := Round(totalGreen * ratio);
      pt1.B := Round(totalBlue * ratio);
    end;
  end;
end;


Solve 4:

{ ... }
type
  TRGBArray = array[0..32767] of TRGBTriple;
  pRGBArray = ^TRGBArray;

procedure TForm1.SmoothResize(abmp: TBitmap; NuWidth, NuHeight: Integer);
var
  xscale, yscale: Single;
  sfrom_y, sfrom_x: Single;
  ifrom_y, ifrom_x: Integer;
  to_y, to_x: Integer;
  weight_x, weight_y: array[0..1] of Single;
  weight: Single;
  new_red, new_green: Integer;
  new_blue: Integer;
  total_red, total_green: Single;
  total_blue: Single;
  ix, iy: Integer;
  bTmp: TBitmap;
  sli, slo: pRGBArray;
begin
  abmp.PixelFormat := pf24bit;
  bTmp := TBitmap.Create;
  bTmp.PixelFormat := pf24bit;
  bTmp.Width := NuWidth;
  bTmp.Height := NuHeight;
  xscale := bTmp.Width / (abmp.Width - 1);
  yscale := bTmp.Height / (abmp.Height - 1);
  for to_y := 0 to bTmp.Height - 1 do
  begin
    sfrom_y := to_y / yscale;
    ifrom_y := Trunc(sfrom_y);
    weight_y[1] := sfrom_y - ifrom_y;
    weight_y[0] := 1 - weight_y[1];
    for to_x := 0 to bTmp.Width - 1 do
    begin
      sfrom_x := to_x / xscale;
      ifrom_x := Trunc(sfrom_x);
      weight_x[1] := sfrom_x - ifrom_x;
      weight_x[0] := 1 - weight_x[1];
      total_red := 0.0;
      total_green := 0.0;
      total_blue := 0.0;
      for ix := 0 to 1 do
      begin
        for iy := 0 to 1 do
        begin
          sli := abmp.Scanline[ifrom_y + iy];
          new_red := sli[ifrom_x + ix].rgbtRed;
          new_green := sli[ifrom_x + ix].rgbtGreen;
          new_blue := sli[ifrom_x + ix].rgbtBlue;
          weight := weight_x[ix] * weight_y[iy];
          total_red := total_red + new_red * weight;
          total_green := total_green + new_green * weight;
          total_blue := total_blue + new_blue * weight;
        end;
      end;
      slo := bTmp.ScanLine[to_y];
      slo[to_x].rgbtRed := Round(total_red);
      slo[to_x].rgbtGreen := Round(total_green);
      slo[to_x].rgbtBlue := Round(total_blue);
    end;
  end;
  abmp.Width := bTmp.Width;
  abmp.Height := bTmp.Height;
  abmp.Canvas.Draw(0, 0, bTmp);
  bTmp.Free;
end;


Solve 5:

Try this routine. I've used it for resizing a large number of bitmaps, and it worked pretty well for me. This preserves the aspect ratio of the bitmap, too.

function GetScaledCenteredBitmap(aFilename: string; maxWidth, maxHeight: integer):
  TBitmap;
var
  bmp, sbmp: TBitmap;
  scaledWidth, scaledHeight: integer;
begin
  scaledWidth := 0;
  scaledHeight := 0;
  bmp := TBitmap.Create;
  sbmp := TBitmap.Create;
  bmp.LoadFromFile(aFilename);
  if bmp.Width > bmp.Height then
  begin
    scaledHeight := trunc(maxWidth * bmp.Height / bmp.Width);
    scaledWidth := maxWidth;
  end
  else if bmp.Height > bmp.Width then
  begin
    scaledWidth := trunc(maxHeight * bmp.Width / bmp.Height);
    scaledHeight := maxHeight;
  end;
  sbmp.Width := maxWidth;
  sbmp.Height := maxHeight;
  sbmp.Canvas.Brush.Color := clBlack;
  sbmp.Canvas.FillRect(Bounds(0, 0, maxWidth, maxHeight));
  sbmp.Canvas.StretchDraw(Bounds(maxWidth div 2 - scaledWidth div 2, maxHeight div 2 -
    scaledHeight div 2, scaledWidth, scaledHeight), bmp);
  result := sbmp;
  bmp.Free;
end;


Answer 6:

This is a modification of Answer 4 and is about three times faster:

procedure SmoothResize2(abmp: TBitmap; NuWidth, NuHeight: integer);
var
  xscale, yscale: Single;
  sfrom_y, sfrom_x: Single;
  ifrom_y, ifrom_x: Integer;
  to_y, to_x: Integer;
  weight_x, weight_y: array[0..1] of Single;
  weight: Single;
  new_red, new_green: Integer;
  new_blue: Integer;
  total_red, total_green: Single;
  total_blue: Single;
  ix, iy: Integer;
  bTmp: TBitmap;
  sli, slo: pRGBArray;
  {pointers for scanline access}
  liPByte, loPByte, p: PByte;
  {offset increment}
  liSize, loSize: integer;
begin
  abmp.PixelFormat := pf24bit;
  bTmp := TBitmap.Create;
  bTmp.PixelFormat := pf24bit;
  bTmp.Width := NuWidth;
  bTmp.Height := NuHeight;
  xscale := bTmp.Width / (abmp.Width - 1);
  yscale := bTmp.Height / (abmp.Height - 1);
  liPByte := abmp.Scanline[0];
  liSize := integer(abmp.Scanline[1]) - integer(liPByte);
  loPByte := bTmp.Scanline[0];
  loSize := integer(bTmp.Scanline[1]) - integer(loPByte);
  for to_y := 0 to bTmp.Height - 1 do
  begin
    sfrom_y := to_y / yscale;
    ifrom_y := Trunc(sfrom_y);
    weight_y[1] := sfrom_y - ifrom_y;
    weight_y[0] := 1 - weight_y[1];
    for to_x := 0 to bTmp.Width - 1 do
    begin
      sfrom_x := to_x / xscale;
      ifrom_x := Trunc(sfrom_x);
      weight_x[1] := sfrom_x - ifrom_x;
      weight_x[0] := 1 - weight_x[1];
      total_red := 0.0;
      total_green := 0.0;
      total_blue := 0.0;
      for ix := 0 to 1 do
      begin
        for iy := 0 to 1 do
        begin
          p := liPByte;
          Inc(p, liSize * (ifrom_y + iy));
          sli := pRGBArray(p);
          new_red := sli[ifrom_x + ix].rgbtRed;
          new_green := sli[ifrom_x + ix].rgbtGreen;
          new_blue := sli[ifrom_x + ix].rgbtBlue;
          weight := weight_x[ix] * weight_y[iy];
          total_red := total_red + new_red * weight;
          total_green := total_green + new_green * weight;
          total_blue := total_blue + new_blue * weight;
        end;
      end;
      p := loPByte;
      Inc(p, loSize * to_y);
      slo := pRGBArray(p);
      slo[to_x].rgbtRed := Round(total_red);
      slo[to_x].rgbtGreen := Round(total_green);
      slo[to_x].rgbtBlue := Round(total_blue);
    end;
  end;
  abmp.Width := bTmp.Width;
  abmp.Height := bTmp.Height;
  abmp.Canvas.Draw(0, 0, bTmp);
  bTmp.Free;
end;