function BitmapToRegion(bmp: TBitmap; TransparentColor: TColor): HRGN;
const
AllocUnit = 100;
type
PRectArray = ^TRectArray;
TRectArray =
array[0..(MaxInt
div SizeOf(TRect)) - 1]
of TRect;
var
pr: PRectArray;
// used to access the rects array of RgnData by index
h: HRGN;
// Handles to regions
RgnData: PRgnData;
// Pointer to structure RGNDATA used to create regions
x, y, x0: Integer;
// coordinates of current rect of visible pixels
maxRects: Cardinal;
// Number of rects to realloc memory by chunks of AllocUnit
begin
Result := 0;
maxRects := AllocUnit;
GetMem(RgnData, SizeOf(RGNDATAHEADER) + (SizeOf(TRect) * maxRects));
try
with RgnData^.rdh
do
begin
dwSize := SizeOf(RGNDATAHEADER);
iType := RDH_RECTANGLES;
nCount := 0;
nRgnSize := 0;
SetRect(rcBound, MAXLONG, MAXLONG, 0, 0);
end;
for y := 0
to bmp.Height - 1
do
begin
x := 0;
while x < bmp.Width - 1
do
begin
// Pixel suchen die der transp. Farbe entsprechen & x solange erhöhen
x0 := x;
while x < bmp.Width - 1
do
begin
// ohne scanline zu Testzwecken - mit (Windows.)GetPixel
if GetPixel(bmp.Canvas.Handle, x, y) = DWORD(TransparentColor)
then break;
Inc(x);
end;
// test to see if we have a non-transparent area in the image
if x > x0
then
begin
// increase RgnData by AllocUnit rects if we exceeds maxRects
if RgnData^.rdh.nCount >= maxRects
then
begin
Inc(maxRects, AllocUnit);
ReallocMem(RgnData, SizeOf(RGNDATAHEADER) + (SizeOf(TRect) * MaxRects));
end;
// Add the rect (x0, y)-(x, y+1) as a new visible area in the region
pr := @RgnData^.Buffer;
// Buffer is an array of rects
with RgnData^.rdh
do
begin
SetRect(pr[nCount], x0, y, x, y + 1);
// adjust the bound rectangle of the region if we are "out-of-bounds"
if x0 < rcBound.Left
then rcBound.Left := x0;
if y < rcBound.Top
then rcBound.Top := y;
if x > rcBound.Right
then rcBound.Right := x;
if y + 1 > rcBound.Bottom
then rcBound.Bottom := y + 1;
Inc(nCount);
end;
end;
// if x > x0
// Need to create the region by muliple calls to ExtCreateRegion, 'cause
// it will fail on Windows 98 if the number of rectangles is too large
if RgnData^.rdh.nCount = 2000
then
begin
h := ExtCreateRegion(
nil, SizeOf(RGNDATAHEADER) + (SizeOf(TRect) * maxRects), RgnData^);
if Result > 0
then
begin // Expand the current region
CombineRgn(Result, Result, h, RGN_OR);
DeleteObject(h);
end
else // First region, assign it to Result
Result := h;
RgnData^.rdh.nCount := 0;
SetRect(RgnData^.rdh.rcBound, MAXLONG, MAXLONG, 0, 0);
end;
Inc(x);
end;
// scan every sample byte of the image
end;
// need to call ExCreateRegion one more time because we could have left
// a RgnData with less than 2000 rects, so it wasn't yet created/combined
h := ExtCreateRegion(
nil, SizeOf(RGNDATAHEADER) + (SizeOf(TRect) * MaxRects), RgnData^);
if Result > 0
then
begin
CombineRgn(Result, Result, h, RGN_OR);
DeleteObject(h);
end else
Result := h;
finally
FreeMem(RgnData, SizeOf(RGNDATAHEADER) + (SizeOf(TRect) * MaxRects));
end;
end;
procedure TForm1.FormCreate(Sender: TObject);
var
ARgn: HRGN;
ABitmap: TBitmap;
begin
ABitmap := TBitmap.Create;
try
ARgn := BitmapToRegion(Image1.Picture.Bitmap, clFuchsia);
SetWindowRgn(Form1.Handle, ARgn, True);
finally
ABitmap.Free;
end;
end;