Программирование на Delphi

FAQ VCL
Графика

:: Меню ::

:: На главную ::

:: FAQ ::

:: Заметки ::

:: Практика ::

:: Win API ::

:: Проекты ::

:: Скачать ::

:: Секреты ::

:: Ссылки ::

:: Сервис ::

:: Написать ::

:: MVP ::

:: RSS ::

Как изменить цветовые каналы битового изображения?


function SetRGBChannelValue( Bitmap: TBitmap; Red, Green, Blue: Integer ): boolean;
var
  i, j: Integer;
  rgbc: array[0..2] of Byte;
  c: TColor;
  r, g, b: Byte;
begin
   if ( Red = 0 ) and ( Green = 0 ) and ( Blue = 0 ) then
   begin
      Result := false;
      Exit;
   end;

   for i := 0 to Bitmap.Height do
   begin
      for j := 0 to Bitmap.Width do
      begin
         c := Bitmap.Canvas.Pixels[j, i];
         rgbc[0] := GetRValue(c);
         rgbc[1] := GetGValue(c);
         rgbc[2] := GetBValue(c);

         if not ( rgbc[0] + Red < 0 ) and not ( rgbc[0] + Red > 255 ) then
            rgbc[0] := rgbc[0] + Red;
         if not ( rgbc[1] + Green < 0 ) and not ( rgbc[1] + Green > 255 ) then
            rgbc[1] := rgbc[1] + Green;
         if not ( rgbc[2] + Blue < 0 ) and not ( rgbc[2] + Blue > 255 ) then
            rgbc[2] := rgbc[2] + Blue;

         r := rgbc[0];
         g := rgbc[1];
         b := rgbc[2];

         Bitmap.Canvas.Pixels[j, i] := RGB( r, g, b );
      end;
   end;
   Result := true;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
   SetRGBChannelValue( FBitmap, 10, 50, 180 );
end;

Как изменить контрастность изображения?


// Спрсоб первый
/// <summary>
/// Изменение контрастности изображения
/// </summary>
/// <param name="Value">значение контрастности на отрезке [-100..100]</param>
/// <param name="Local">true - применяется "местный контраст", false - "общий" (более красивый)</param>
procedure Contrast(Bitmap: TBitmap; Value: Integer; Local: Boolean);

  function BLimit(B: Integer): Byte;
  begin
     if B < 0 then
        Result := 0
     else if B > 255 then
        Result := 255
     else
        Result := B;
  end;

var
  Dest: pRGBTriple;
  x, y, mr, mg, mb, W, H, tr, tg, tb: Integer;
  vd: Double;
begin
   if Value = 0 then Exit;

   W := Bitmap.Width - 1;
   H := Bitmap.Height - 1;
   if Local then
   begin
      mR := 128;
      mG := 128;
      mB := 128;
   end
   else
   begin
      tr := 0;
      tg := 0;
      tb := 0;
      for y := 0 to H do
      begin
         Dest := Bitmap.ScanLine[y];
         for x := 0 to W do
         begin
            with Dest^ do
            begin
               Inc( tb, rgbtBlue );
               Inc( tg, rgbtGreen );
               Inc( tr, rgbtRed );
            end;
            Inc( Dest );
         end;
      end;
      mB := Trunc( tb / ( W * H ) );
      mG := Trunc( tg / ( W * H ) );
      mR := Trunc( tr / ( W * H ) );
   end;

   if Value > 0 then
      vd := 1 + ( Value / 10)
   else
      vd := 1 - ( Sqrt( -Value ) / 10 );

   for y := 0 to H do
   begin
      Dest := Bitmap.ScanLine[y];
      for x := 0 to W do
      begin
         with Dest^ do
         begin
            rgbtBlue := BLimit( mB + Trunc( ( rgbtBlue - mB ) * vd ) );
            rgbtGreen := BLimit( mG + Trunc( ( rgbtGreen - mG ) * vd ) );
            rgbtRed := BLimit( mR + Trunc( ( rgbtRed - mR ) * vd ) );
         end;
         Inc( Dest );
      end;
   end;
end;

// Спрсоб второй
uses
  {...,} Math;

procedure Gamma( Bitmap: TBitmap; L: Double ); {0.0 < L < 7.0}
type
  pRGB = ^TRGB;
  TRGB = record
    B, G, R: Byte;
  end;
var
  Dest: pRGB;
  X, Y: Word;
  GT: array[0..255] of Byte;
begin
   Bitmap.PixelFormat := pf24Bit;
   GT[0] := 0;
   if L = 0 then
      L := 0.01;
   for X := 1 to 255 do
      GT[X] := Round( 255 * Power( X / 255, 1 / L ) );
   for Y := 0 to Bitmap.Height-1 do
   begin
      Dest := Bitmap.ScanLine[y];
      for X := 0 to Bitmap.Width-1 do
      begin
         with Dest^ do
         begin
            R := GT[R];
            G := GT[G];
            B := GT[B];
         end;
         Inc( Dest );
      end;
   end;
end;

Как отобразить Bitmap зеркально?


// Способ первый
procedure FlipBitmap( Bitmap: TBitmap; FlipHor: Boolean );
var
  x, y, W, H: Integer;
  Pixel_1, Pixel_2: PRGBTriple;
  MemPixel: TRGBTriple;
begin
   Bitmap.PixelFormat := pf24Bit;
   W := Bitmap.Width-1;
   H := Bitmap.Height-1;
   if FlipHor then {отражение по горизонтали}
      for y := 0 to H do
      begin
         // помещаем оба указателя на строку H:
         Pixel_1 := Bitmap.ScanLine[y];
         Pixel_2 := Bitmap.ScanLine[y];
         // помещаем второй указатель в конец строки:
         Inc( Pixel_2, W );
         // цикл идёт только до середины строки:
         for x := 0 to W div 2 do
         begin
            // симметричные точки обмениваются цветами:
            MemPixel := Pixel_1^;
            Pixel_1^ := Pixel_2^;
            Pixel_2^ := MemPixel;
            Inc( Pixel_1 ); // смещаем указатель вправо
            Dec( Pixel_2 ); // смещаем указатель влево
         end;
      end
   else // отражение по вертикали
      // цикл идёт только до средней строки:
      for y := 0 to H div 2 do
      begin
         // помещаем первый указатель на строку H,
         // а второй на строку симметричную H:
         Pixel_1 := Bitmap.ScanLine[y];
         Pixel_2 := Bitmap.ScanLine[H-y];
         for x := 0 to W do
         begin
            // симметричные точки обмениваются цветами:
            MemPixel := Pixel_1^;
            Pixel_1^ := Pixel_2^;
            Pixel_2^ := MemPixel;
            Inc(Pixel_1); // смещаем указатель вправо
            Inc(Pixel_2); // смещаем указатель вправо
         end;
     end;
end;

Как заменить все цвета Bitmap`a оттенками одного цвета?


procedure ModColors( Bitmap: TBitmap; Color: TColor );

  function BLimit(B: Integer): Byte;
  begin
    if B < 0 then
      Result := 0
    else if B > 255 then
      Result := 255
    else
      Result := B;
  end;

type
  pRGB = ^TRGB;
  TRGB = record
    B, G, R: Byte;
  end;
var
  r1, g1, b1: Byte;
  x, y: Integer;
  Dest: pRGB;
  A: Double;
begin
   Bitmap.PixelFormat := pf24Bit;
   r1 := Round( 255 / 100 * GetRValue( Color ) );
   g1 := Round( 255 / 100 * GetGValue( Color ) );
   b1 := Round( 255 / 100 * GetBValue( Color ) );
   for y := 0 to Bitmap.Height - 1 do
   begin
      Dest := Bitmap.ScanLine[y];
      for x := 0 to Bitmap.Width-1 do
      begin
         with Dest^ do
         begin
            A := ( r + b + g ) / 300;
            with Dest^ do
            begin
               R := BLimit( Round( r1 * A ) );
               G := BLimit( Round( g1 * A ) );
               B := BLimit( Round( b1 * A ) );
            end;
         end;
         Inc( Dest );
      end;
   end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
   ModColors( FBitmap, RGB( 218, 219, 230 ) );
end;

Как залить канву градиентом?


// Способ первый
type
  TOrientation = ( orVertical, orHorizontal );

  TForm1 = class(TForm)
    procedure FormPaint(Sender: TObject);
  private
    procedure PaintGradientRect( StartColor, EndColor: TColor;
      Orientation: TOrientation );
    procedure PaintGradientTriangle;
  end;

  // Переопределение типа из Windows.pas
  COLOR16 = $0000..$FF00;

  TTriVertex = packed record
    x, y: DWORD; // Координаты вершины
    Red, Green, Blue, Alpha: COLOR16; // Каналы цветов
  end;

  function GradientFill( DC: HDC; Vertex: Pointer; NumVertex: Cardinal;
    Mesh: Pointer; NumMesh, Mode: DWORD ): BOOL; stdcall;
    external 'msimg32.dll' name 'GradientFill';

{...}

implementation

{...}

procedure TForm1.PaintGradientRect(StartColor, EndColor: TColor;
  Orientation: TOrientation);
var 
  // Массив вершин (нужны две - верхнелевая и нижнеправая)
  vert: array[0..1] of TTriVertex;
  gRect: TGradientRect; // Индексы вершин в массиве vert (из Windows.pas)
begin
   // Определяем вершины
   vert[0].x := 0; // Верхняя левая точка
   vert[0].y := 0;
   vert[0].Red := GetRValue( StartColor ) shl 8;
   vert[0].Green := GetGValue( StartColor ) shl 8;
   vert[0].Blue := GetBValue( StartColor ) shl 8;
   vert[0].Alpha := $0000; // Видать прозрачность?..

   vert[1].x := ClientWidth; // Нижняя правая точка
   vert[1].y := ClientHeight;
   vert[1].Red := GetRValue( EndColor ) shl 8;
   vert[1].Green := GetGValue( EndColor ) shl 8;
   vert[1].Blue := GetBValue( EndColor ) shl 8;
   vert[1].Alpha := $0000;

   gRect.UpperLeft := 0; // Назначаем вершины верхнелевому
   gRect.LowerRight := 1; // и нижнеправому углам.

   // Заливаем в зависимости от ориентации
   if Orientation = orHorizontal then
      GradientFill( Canvas.Handle, @vert, 2, @gRect, 1, GRADIENT_FILL_RECT_H )
   else
      GradientFill( Canvas.Handle, @vert, 2, @gRect, 1, GRADIENT_FILL_RECT_V );
end;

procedure TForm1.PaintGradientTriangle;
var
  vert: array[0..3] of TTriVertex; // 4 точки для 2 треугольников<
  gTri: array[0..1] of TGradientTriangle; // массив из 2 треугольников
begin
   // Красная вершина
   vert[0].x := 80;
   vert[0].y := 50;
   vert[0].Alpha := $0000;
   vert[0].Red := $FF00;
   vert[0].Green := $0000;
   vert[0].Blue := $0000;

   // Желтая вершина
   vert[1].x := 50;
   vert[1].y := 120;
   vert[1].Alpha := $0000;
   vert[1].Red := $FF00;
   vert[1].Green := $FF00;
   vert[1].Blue := $0000;

   // Синяя вершина
   vert[2].x := 150;
   vert[2].y := 80;
   vert[2].Alpha := $0000;
   vert[2].Red := $0000;
   vert[2].Green := $0000;
   vert[2].Blue := $FF00;

   // Зеленая вершина
   vert[3].x := 120;
   vert[3].y := 150;
   vert[3].Alpha := $0000;
   vert[3].Red := $0000;
   vert[3].Green := $FF00;
   vert[3].Blue := $0000;

   // Назначаем индексы вершин углам треугольников
   gTri[0].Vertex1 := 0; gTri[0].Vertex2 := 1; gTri[0].Vertex3 := 2;
   gTri[1].Vertex1 := 3; gTri[1].Vertex2 := 1; gTri[1].Vertex3 := 2;

   // Рисуем красивый градиент
   GradientFill( Canvas.Handle, @vert, 4, @gTri, 2, GRADIENT_FILL_TRIANGLE );
end;

procedure TForm1.FormPaint(Sender: TObject);
begin
   PaintGradientRect( clRed, clLime, orVertical );
   PaintGradientTriangle;
end;

// **********************************************
// В полседних версиях Delphi это уже реализовано
// **********************************************
uses
  GraphUtil;

procedure TForm1.FormPaint(Sender: TObject);
begin
   GradientFillCanvas( Canvas, clMaroon, clWhite, ClientRect, gdVertical );
end;

// Способ второй
procedure TForm1.Button1Click(Sender: TObject);
const
  N = 200;
  M = 100;
var
  i, j, a: Integer;
begin
   a := 255 div N;
   for i := 1 to N do
      for j := 1 to M do
         Form1.Canvas.Pixels[20+i, 30+j] := RGB( 255, 255-i*a, 255 );
end;

// Способ третий
procedure TForm1.Button1Click(Sender: TObject);
var
  StartC, EndC: TColor; // Начальный и конечный цвета
  GradRECT: TRect; // Размер области, на которой будем рисовать
  StartRGB, EndRGB: array[0..2] of Byte; // Разложенный цвет
  Colors, i, Delta: Word; // Число цветов, которые использовать для создания градиента
begin
   // Область заливки
   GradRECT := Image1.ClientRect;
   // Цвета
   StartC := ColorToRGB( clRed );
   EndC := ColorToRGB( clLime );
   // Массив с исходными цветами (1)
   StartRGB[0] := GetRValue( StartC );
   StartRGB[1] := GetGValue( StartC );
   StartRGB[2] := GetBValue( StartC );
   // Массив с конечными цветами (2)
   EndRGB[0] := GetRValue( EndC );
   EndRGB[1] := GetGValue( EndC );
   EndRGB[2] := GetBValue( EndC );
   // Число градаций на ширину
   Colors := Image1.Width div 2;
   // Число пикселей для одной градации
   Delta := Image1.Width div Colors;
   for i := 0 to Colors do
   begin
      // Определяем область для градации
      GradRECT.Left := i * Delta;
      GradRECT.Right := GradRECT.Left + Delta;
      with Image1.Canvas do
      begin
         Pen.Style := psSolid;
         Brush.Color := RGB( ( StartRGB[0] + MulDiv( i, EndRGB[0] - StartRGB[0], Colors{-1} ) ),
                             ( StartRGB[1] + MulDiv( i, EndRGB[1] - StartRGB[1], Colors{-1} ) ),
                             ( StartRGB[2] + MulDiv( i, EndRGB[2] - StartRGB[2], Colors{-1} ) ) );
         // Заливаем
         FillRect( GradRect );
      end;
   end;
end;

Как просмотреть все стили кисти?


var
  BrushStyle: byte = 0;

implementation

uses
  {...,} TypInfo;

procedure TForm1.FormCreate(Sender: TObject);
begin
   Caption := GetEnumName( TypeInfo( TBrushStyle ), BrushStyle );
end;

procedure TForm1.FormPaint(Sender: TObject);
begin
   with Canvas do
   begin
      Brush.Style:= bsSolid;
      Brush.Color:= clWhite;
      Rectangle( 0, 0, ClientWidth, ClientHeight );

      Brush.Style := TBrushStyle( BrushStyle );
      Brush.Color := clRed;
      Rectangle( 0, 0, ClientWidth, ClientHeight );
   end;
end;

// Timer1.Interval = 1000
procedure TForm1.Timer1Timer(Sender: TObject);
begin
   Inc( BrushStyle );
   if BrushStyle > 7 then
      BrushStyle := 0;
   InvalidateRect( Handle, nil, false );
   Caption := GetEnumName( TypeInfo( TBrushStyle ), BrushStyle );
end;

Как преобразовать EMF (Enhanced Metafile) в BMP?


// Способ первый
procedure TForm1.Button1Click(Sender: TObject);
var
  Bitmap: TBitmap;
  Met: TMetafile;
begin
   Bitmap := TBitmap.Create;
   Metafile := TMetafile.Create;
   Metafile.LoadFromFile( 'c:\test.emf' );
   Bitmap.Width := Metafile.Width;
   Bitmap.Height := Metafile.Height;
   Bitmap.Canvas.Draw( 0, 0, Metafile );
   Bitmap.SaveToFile( 'c:\test.bmp' );
   Metafile.Free;
   Bitmap.Free;
end;

// Способ второй
procedure ConvertEMF2BMP( const EMFFileName, BMPFileName: TFileName );
var
  p: Pointer;
  Metafile: TMetafile;
  Bitmap: TBitmap;
begin
   Metafile := TMetaFile.Create;
   try
      Bitmap := TBitmap.Create;
      try
         Metafile.LoadFromFile( EMFFileName );
         Bitmap.Width := Metafile.Width;
         Bitmap.Height := Metafile.Height;
         Bitmap.SetSize( Metafile.Width, Metafile.Height );
         PlayEnhMetaFile( Bitmap.Canvas.Handle, Metafile.Handle, Bitmap.Canvas.ClipRect );
      finally
         Metafile.Free;
      end;
      Bitmap.SaveToFile( BMPFileName );
   finally
      Bitmap.Free;
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
   ConvertEMF2BMP( 'c:\123456.emf', 'c:\123456.bmp' );
end;

Как сделать эффект "муравьев"?


const
  ANT_WIDTH = 10;
  ANT_MOVE_STEP = 2;

var
  antPos: Word = 0;

procedure ant_Line( x1, y1, x2, y2: integer; Canvas: TCanvas; Otstup, Interval: Word );
var
  i, d, a, b: Word;
  znx, zny: SmallInt;
  px, py: integer;
begin
   d := Trunc( Sqrt( Sqr( x2-x1 ) + Sqr( y2-y1 ) ) );
   znx := 1;
   zny := 1;
   if x2-x1 < 0 then
      znx := -1;
   if y2-y1 < 0 then
      zny := -1;
   a := Trunc( Interval * ( x2-x1 ) * znx / d );
   b := Trunc( Interval * ( y2-y1 ) * zny / d );
   if Otstup >= Interval * 2 then
      Otstup := Otstup mod ( Interval * 2 );
   for i := 0 to Trunc( d / Interval ) do
   begin
      if i mod 2 <> 0 then
         Continue;
      px := x1 + i * a * znx + Trunc( Otstup * ( x2-x1 ) / d );
      py := y1 + i * b * zny + Trunc( Otstup * ( y2-y1 ) / d );
      if ( d < Trunc( Sqrt( Sqr( px-x1 ) + Sqr( py-y1 ) ) ) ) or
         ( ( px * znx > x2 ) or ( py * zny > y2 ) ) then
         Continue;
      Canvas.MoveTo( px, py );
      px := x1 + ( i+1 ) * a * znx + Trunc( Otstup * ( x2-x1 ) / d );
      py := y1 + ( i+1 ) * b * zny + Trunc( Otstup * ( y2-y1 ) / d );
      if d < Trunc( Sqrt( Sqr( px-x1 ) + Sqr( py-y1 ) ) ) then
      begin
         px := x2;
         py := y2;
      end;
      if px * znx > x2 then
         px := x2;
      if py * zny > y2 then
         py := y2;
      Canvas.LineTo( px, py );
      if Otstup > Interval then
      begin
         Canvas.MoveTo( x1, y1 );
         px := x1 + Trunc( ( Otstup-Interval ) * ( x2-x1 ) / d );
         py := y1 + Trunc( ( Otstup-Interval ) * ( y2-y1 ) / d );
         Canvas.LineTo( px, py );
      end;
   end;
end;

// Otstup - смещение для рисования "муравьев"
// Interval - длина линий ("муравьев")
procedure ant_Rectangle( x1, y1, x2, y2: integer; Canvas: TCanvas; Otstup, Interval: Word );
var
  pogr, pogr1: Word;
begin
   if ( x1 = x2 ) or ( y1 = y2 ) then Exit;
   ant_Line( x1, y1, x2, y1, Canvas, Otstup, Interval );
   pogr := ( Abs( x2-x1 ) div Interval ) mod 2;
   if pogr = 0 then
      pogr := Interval * 2 - ( Abs( x2-x1 ) mod ( Interval ) )
   else
      pogr :=Interval - ( Abs( x2-x1 ) mod ( Interval ) );
   ant_Line( x2, y1, x2, y2, Canvas, Otstup + pogr, Interval );
   pogr1 := ( Abs( y1-y2 ) div Interval ) mod 2;
   if pogr1 = 0 then
      pogr1 := Interval * 2 - ( abs ( y1-y2 ) mod ( Interval ) )
   else
      pogr1 := Interval - ( Abs( y1-y2 ) mod ( Interval ) );
   ant_Line( x2, y2, x1, y2, Canvas, Otstup + pogr + pogr1, Interval );
   ant_Line( x1, y2, x1, y1, Canvas, otstup + 2 * pogr + pogr1, Interval );
end;

// Timer.Interval = 50
procedure TForm1.Timer1Timer(Sender: TObject);
begin
   Refresh;
   Canvas.Pen.Width := 2;
   Canvas.Pen.Color := clNavy;
   ant_Rectangle( 10, 10, 200, 200, Canvas, antPos, ANT_WIDTH );
   antPos := antPos + ANT_MOVE_STEP;
   if antPos >= ANT_WIDTH * 2 then
      antPos := 0;
end;

Как ограничить область рисования на канве?


// Установка области клиппинга - данные вне этой области не отображаются
procedure TForm1.Button1Click(Sender: TObject);
var
  ClipRect: TRect;
begin
   ClipRect := ClientRect;
   with ClipRect do
   begin
      InflateRect( ClipRect, -( Right div 4 ), -( Bottom div 4 ) );
      IntersectClipRect( Canvas.Handle, Left, Top, Right, Bottom );
   end;

   Canvas.Brush.Color := clWhite;
   Canvas.FillRect( ClientRect );
end;

// Удаление области рисования - данные в этой области не отображаются
procedure TForm1.Button1Click(Sender: TObject);
var
  ClipRect: TRect;
begin
   ClipRect := ClientRect;
   with ClipRect do
   begin
      InflateRect( ClipRect, -( Right div 4 ), -( Bottom div 4 ) );
      ExcludeClipRect( Canvas.Handle, Left, Top, Right, Bottom );
   end;

   Canvas.Brush.Color := clWhite;
   Canvas.FillRect( ClientRect );
end;

Как нарисовать Bitmap с прозрачностью?


procedure DrawTransparentBmp( Canvas: TCanvas; X,Y: Integer; Bmp: TBitmap;
                              clTransparent: TColor );
var
  bmpXOR, bmpAND, bmpINVAND, bmpTarget: TBitmap;
  OldCol: Longint;
begin
   try
      bmpAND := TBitmap.Create;
      bmpAND.Width := Bmp.Width;
      bmpAND.Height := Bmp.Height;
      bmpAND.Monochrome := True;
      OldCol := SetBkColor( Bmp.Canvas.Handle, ColorToRGB( clTransparent ) );
      BitBlt( bmpAND.Canvas.Handle, 0, 0, Bmp.Width,Bmp.Height, Bmp.Canvas.Handle, 0, 0, SRCCOPY );
      SetBkColor( Bmp.Canvas.Handle, OldCol );
      bmpINVAND := TBitmap.Create;
      bmpINVAND.Width := Bmp.Width;
      bmpINVAND.Height := Bmp.Height;
      bmpINVAND.Monochrome := True;
      BitBlt( bmpINVAND.Canvas.Handle, 0, 0, Bmp.Width,Bmp.Height, bmpAND.Canvas.Handle, 0, 0, NOTSRCCOPY );
      bmpXOR := TBitmap.Create;
      bmpXOR.Width := Bmp.Width;
      bmpXOR.Height := Bmp.Height;
      BitBlt( bmpXOR.Canvas.Handle, 0, 0, Bmp.Width,Bmp.Height, Bmp.Canvas.Handle, 0, 0, SRCCOPY );
      BitBlt( bmpXOR.Canvas.Handle, 0, 0, Bmp.Width, Bmp.Height, bmpINVAND.Canvas.Handle, 0, 0, SRCAND );
      bmpTarget := TBitmap.Create;
      bmpTarget.Width := Bmp.Width;
      bmpTarget.Height := Bmp.Height;
      BitBlt( bmpTarget.Canvas.Handle, 0, 0, Bmp.Width, Bmp.Height, Canvas.Handle, X, Y, SRCCOPY );
      BitBlt( bmpTarget.Canvas.Handle, 0, 0, Bmp.Width, Bmp.Height, bmpAND.Canvas.Handle, 0, 0, SRCAND );
      BitBlt( bmpTarget.Canvas.Handle, 0, 0, Bmp.Width, Bmp.Height, bmpXOR.Canvas.Handle, 0, 0, SRCINVERT );
      BitBlt( Canvas.Handle, X, Y, Bmp.Width,Bmp.Height, bmpTarget.Canvas.Handle, 0, 0, SRCCOPY );
   finally
      bmpXOR.Free;
      bmpAND.Free;
      bmpINVAND.Free;
      bmpTarget.Free;
   end;
end;

При использовании материала - ссылка на сайт обязательна