## 2011. május 8., vasárnap

### 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 ?

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;
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;
if yP shr 16 < src.Height - 1 then
Read2 := src.ScanLine[yP shr 15 + 1]
else
pc := Dst.scanline[y];
z2 := yP and \$7FFF;
iz2 := \$8000 - z2;
for x := 0 to Dst.Width - 1 do
begin
t := xP shr 15;
Col1g := Read[t * 3 + 1];
Col1b := Read[t * 3 + 2];
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;
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;

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;