function CreateRgnFromBitmap(Bitmap: TBitmap): HRGN;
const
// Начальное резервируемое количество прямоугольников в регионе.
// Можно присвоить и другое число.
 dCount = 500;
var
 PLine: Pointer;       // Указатель на строку в рисунке
 PPixel: PLongint;     // Указатель на пиксел в рисунке
 DataMem: PRgnData;    // Здесь будут храниться данные о регионе
 H: THandle;           // Дескриптор области памяти
 MaxRects: DWORD;      // Резервируемое количество прямоугольников в регионе
 X,StartX,FinishX,Y: integer; // Понадобятся при добавлении прямоугольников
 TransColor: TColor;          // Прозрачный цвет
 TransR,TransG,TransB: Byte;  // Значения R, G и B прозрачного цвета
 TempBitmap: TBitmap;         // Временный Bitmap
 // Функция возвращает true, если цвет Pixel совпадает с прозрачным
 function IsTrans(Pixel: Longint): boolean;
 var
   R,G,B: Byte;
 begin
   R:=GetBValue(Pixel);
   G:=GetGValue(Pixel);
   B:=GetRValue(Pixel);
   Result:=(TransR = R) and (TransG = G) and (TransB = B);
 end;
 // Процедура добавляет прямоугольник (StartX, Y, FinishX, Y+1) к региону
 procedure AddRect;
 var
   Rect: PRect;
 begin
   Rect:=@DataMem^.Buffer[DataMem^.rdh.nCount*SizeOf(TRect)];
   SetRect(Rect^,StartX,Y,FinishX,Y+1);
   Inc(DataMem^.rdh.nCount);
 end;
begin
 MaxRects:=dCount;          // Начальное значение MaxRects
 // Определяем прозрачный цвет
 TransColor:=GetPixel(Bitmap.Canvas.Handle,0,0);
 TransR:=GetRValue(TransColor);
 TransG:=GetGValue(TransColor);
 TransB:=GetBValue(TransColor);
 // Формируем временный Bitmap, с которым будем работать
 TempBitmap:=TBitmap.Create;
 TempBitmap.Assign(Bitmap);
 TempBitmap.PixelFormat:=pf24bit;   // 24 бита на пиксель
 // Выделяем память на данные для региона и получаем указатель на нее
 H:=GlobalAlloc(GMEM_MOVEABLE,SizeOf(TRgnDataHeader)+
   SizeOf(TRect)*MaxRects);
 DataMem:=GlobalLock(H);
 // Заполняем заголовок
 // Обнуляем все поля в заголовке
 ZeroMemory(@DataMem^.rdh,SizeOf(TRgnDataHeader));
 DataMem^.rdh.dwSize:=SizeOf(TRgnDataHeader);       // Заполняем поле dwSize
 DataMem^.rdh.iType:=RDH_RECTANGLES;                // Заполняем поле iType
 // Начинаем цикл обхода рисунка по точкам. Будем двигаться слева-направо,
 // сверху-вниз. В переменных X и Y будем хранить текущее значение
 // координат.
 // В переменной StartX - начало нового прямоугольника, FinishX -
 // соответственно конец прямоугольника.
 for Y:=0 to TempBitmap.Height-1 do begin     // Цикл по строкам
   PLine:=TempBitmap.ScanLine[Y];// Получаем указатель на строку
   PPixel:=PLongint(PLine);   // Получаем указатель на первую точку в строке
   X:=0; StartX:=0; FinishX:=0;  // Обнуляем X, StartX, FinishX
   while X<TempBitmap.Width do begin      // Цикл по столбцам
     Inc(X);                    // Увеличиваем текущее значение координаты X
     // Если цвет точки отличен от прозрачного,
     // то надо включить ее в новый прямоугольник
     if not IsTrans(PPixel^) then FinishX:=X
     else begin
   // Цвет точки равен прозрачному. Значит нужно завершить формирование
   // прямоугольника, если он не пустой, то добавить его к региону и начать
   // формирование нового прямоугольника. Если количество прямоугольников
   // в регионе достигло MaxRects, то увеличиваем MaxRects на dCount, и
   // выделяем память под данные о регионе заново
       if DataMem^.rdh.nCount>=MaxRects then
       begin
         Inc(MaxRects,dCount);
         GlobalUnlock(H);
         H:=GlobalReAlloc(H,SizeOf(TRgnDataHeader)+SizeOf(TRect)*MaxRects,
           GMEM_MOVEABLE);
         DataMem:=GlobalLock(H);
       end;
       // Если прямоугольник не пустой, добавляем его к региону
       if FinishX>StartX then AddRect;
       // Устанавливаем значения StartX, FinishX для формирования нового
       // прямоугольника
       StartX:=X;
       FinishX:=X;
     end;
     Inc(PByte(PPixel),3); // Получаем указатель не следующую точку рисунка
   end;
 // Возможен следующий случай: если цвет последней точки в строке не равен
 // прозрачному, то FinishX будет больше, чем StartX, однако прямоугольник
 // не будет добавлен к региону, так так добавление нового прямоугольника
 // происходит только если встретился прозрачный пиксель. Это нужно учесть.
   if FinishX>StartX then AddRect;
 end;
 // Временный Bitmap больше не нужен
 TempBitmap.Free;
 try
   // Формируем регион по данным из DataMem^
   Result:=ExtCreateRegion(nil,SizeOf(TRgnDataHeader)+
     SizeOf(TRect)*DataMem^.rdh.nCount,DataMem^);
 finally
   GlobalFree(H); // Освобождаем выделенную память
 end;
end;
. . .
end.