Crop a TBitmap or TBitmap32 automatically

Problem/Question/Abstract:

Does anybody know a component or a piece of Delphi code that performs "smart cropping" automatically, as follows. I have a lot of images with an almost white background and some drawing somewhere in the rectangle. I want to trim off the almost white margins around the drawing automatically (these margins are sometimes very different in size) in order to reduce the weight of the image, and to be able to center the drawing.

Answer:

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

function CropRect(Bitmap: TBitmap; C: TColor): TRect;
var
ScanlinePtr: PByte;
ScanlineIncrement: Integer;
LastScanline: PByte;
X: Integer;
Line: pRGBArray;
AColor: TColor;
r, g, b: Integer;
x1, x2, y1, y2, x3, x4, y3, n: Integer;
begin
Assert(Bitmap.PixelFormat = pf24bit); {must be pf24bit!}
AColor := ColorToRGB(C);
r := GetRValue(AColor);
g := GetGValue(AColor);
b := GetBValue(AColor);
X := Bitmap.Width;
ScanlinePtr := Bitmap.Scanline[0];
ScanlineIncrement := integer(Bitmap.Scanline[1]) - integer(ScanlinePtr);
LastScanline := ScanlinePtr;
Inc(LastScanLine, ScanlineIncrement * Bitmap.Height);
x1 := Bitmap.Width;
x2 := 0;
y1 := 0;
y2 := Bitmap.Height;
y3 := 0;
repeat
Line := pRGBArray(ScanLinePtr);
x3 := -1;
x4 := -1;
n := 0;
while (n < X) and (x3 < 0) do
begin
if (Line[n].rgbtRed <> r) or (Line[n].rgbtGreen <> g) or (Line[n].rgbtBlue <> b)
then
x3 := n;
Inc(n);
end;
n := X - 1;
while (n > -1) and (x4 < 0) do
begin
if (Line[n].rgbtRed <> r) or (Line[n].rgbtGreen <> g) or (Line[n].rgbtBlue <> b)
then
x4 := n;
Dec(n);
end;
if (x3 > -1) and (x3 < x1) then
x1 := x3;
if (x4 > -1) and (x4 > x2) then
x2 := x4;
if (x3 > -1) or (x4 > -1) then
begin
if y1 = 0 then
y1 := y3
else
y2 := y3;
end;
Inc(ScanlinePtr, ScanlineIncrement); {move to the next scanline}
Inc(y3);
until
(ScanlinePtr = LastScanline);
result := Rect(x1, y1, x2 + 1, y2);
if IsRectEmpty(result) then
result := Rect(0, 0, Bitmap.Width, Bitmap.Height);
end;

procedure TForm1.Button1Click(Sender: TObject);
var
r: TRect;
begin
if Assigned(Image1.Picture) then {contains srcBmp}
begin
r := CropRect(srcBmp, FCropColor); {FCropColor is lower left pixel}
cropBmp.Width := r.Right - r.Left;
cropBmp.Height := r.Bottom - r.Top;
cropBmp.Canvas.CopyRect(Rect(0, 0, cropBmp.Width, cropBmp.Height), srcBmp.Canvas,
r);
Image2.Picture.Bitmap.Assign(cropBmp);
end;
end;

This can also be done with palette images (preferably grayscale), in which case only one component (byte) has to be compared, so faster. If you already have a thumbnail, use this one and use the result as a crude initial guess for the final calculation with complete bitmap. If the shape you're after is certain to be connected (no gaps) and concave, there are optimisations possible, like ray casting from top/bottom and left/right, finding the object, then traversing along the edge to find extremes. If you're doing any other operation on the bitmap before, like color conversion or gamma correction, you can use this very operation to already get you the crop box with limited extra effort.

Here's an alternative implementation for TBitmap32. TBitmap32 colors are really cardinals, so only one compare is neccesary per pixel. This implementation also exploits the fact that the bits (pixels) are all aligned in one long row. Another optimisation is that it skips the middle section once it has begun finding "non-white" pixels.

{ ... }
with Bitmap32 do
begin
{Initialisation}
Size := Width * Height;
First := -1;
Left := Width;
Right := -1;
Last := -1;
i := 0;
{Loop through bits, find First, Last, Left and Right}
repeat
if Bits[i] <> CropColor then
begin
if First < 0 then
{Set top row (First div Width)}
First := i;
{X position}
X := i mod Width;
if X < Left then
{Set new left border}
Left := X;
if X > Right then
{Set new right border}
Right := X
else
{Jump to the right border directly}
inc(i, Right - X);
{Set bottom row (Last div Width)}
Last := i;
end;
inc(i);
until
i >= Size;
{Resulting crop rectangle and IsEmpty flag}
CropRect := Rect(Left, First div Width, Right + 1, Last div Width + 1);
IsEmpty := First = -1;
end;