function BitmapToRgn(Image: TBitmap): HRGN;
var
 TmpRgn: HRGN;
 x, y: integer;
 ConsecutivePixels: integer;
 CurrentPixel: TColor;
 CreatedRgns: integer;
 CurrentColor: TColor;
begin
 CreatedRgns := 0;
 Result := CreateRectRgn(0, 0, Image.Width, Image.Height);
 inc(CreatedRgns);

 if (Image.Width = 0) or (Image.Height = 0) then
 exit;

 for y := 0 to Image.Height - 1 do
 begin
 CurrentColor := Image.Canvas.Pixels[0,y];
 ConsecutivePixels := 1;
 for x := 0 to Image.Width - 1 do
 begin
 CurrentPixel := Image.Canvas.Pixels[x,y];

 if CurrentColor = CurrentPixel then
 inc(ConsecutivePixels)
 else
 begin
 // Входим в новую зону
 if CurrentColor = clWhite then
 begin
 TmpRgn := CreateRectRgn(x-ConsecutivePixels, y, x, y+1);
 CombineRgn(Result, Result, TmpRgn, RGN_DIFF);
 inc(CreatedRgns);
 DeleteObject(TmpRgn);
 end;
 CurrentColor := CurrentPixel;
 ConsecutivePixels := 1;
 end;
 end;

 if (CurrentColor = clWhite) and (ConsecutivePixels > 0) then
 begin
 TmpRgn := CreateRectRgn(x-ConsecutivePixels, y, x, y+1);
 CombineRgn(Result, Result, TmpRgn, RGN_DIFF);
 inc(CreatedRgns);
 DeleteObject(TmpRgn);
 end;
 end;
end;