http://forum.delphimaster.net/cgi-bin/forum.pl?id=1594275870&n=7

Динамическое создание курсора


Grig ©   (09.07.20 09:24

Всем привет!

Есть функция, создающая курсор из предоставляемого ей битмапа. При этом она должна накладывать на него стандартный системный курсор, что реализовать не получается.


function TDragToolButtonObject.CreateDragCursor(Bitmap: TBitmap;
 Hotspot: TPoint; MaskColor: TColor): HCURSOR;
var
 CursorBitmap, TempBitmap: TBitmap;
 IconInfo: TIconInfo;
begin
 CursorBitmap := TBitmap.Create;
 try
   with CursorBitmap do
   begin
     if Bitmap.PixelFormat = pfDevice then
       Assign(Bitmap)
     else
     begin
       SetSize(Bitmap.Width, Bitmap.Height);
       PixelFormat := pfDevice;
       Canvas.Draw(0, 0, Bitmap);
     end;
     DrawIcon(Canvas.Handle, Hotspot.X, Hotspot.Y, LoadCursor(0, IDC_ARROW)); // (1)
     TransparentColor := MaskColor;
   end;

   with IconInfo do
   begin
     fIcon := False;
     xHotspot := Hotspot.X;
     yHotspot := Hotspot.Y;
     hbmColor := CursorBitmap.Handle;
     hbmMask := CursorBitmap.MaskHandle;
   end;
   Result := CreateIconIndirect(IconInfo);

   {
   // (2)
   CursorBitmap.SaveToFile(ExtractFilePath(Application.ExeName) + 'hbmColor.bmp');
   TempBitmap := TBitmap.Create;
   try
     TempBitmap.Handle := CursorBitmap.MaskHandle;
     TempBitmap.SaveToFile(ExtractFilePath(Application.ExeName) + 'hbmMask.bmp');
   finally
     TempBitmap.Free;
   end;
   {}

 finally
   CursorBitmap.Free;
 end;
end;


Вызов осуществляется примерно следующий образом:


   Bitmap := TBitmap.Create;
   with Bitmap.Canvas do
   begin
     Brush.Style := bsSolid;
     Brush.Color := clLime;
     FillRect(Bitmap.Canvas.ClipRect);
     Brush := Self.Brush;
     Pen.Color := clBlack;
     Rec := Rect(0, 0, Bitmap.Width div 2, Bitmap.Height div 3);
     Rectangle(Rec);
   end;

   Screen.Cursors[crDragToolButton] := CreateDragCursor(Bitmap, Point(4, 4), clLime);


Если закомментировать строку (1), то созданный курсор выглядит как предполагается. В противном случае, курсов выглядит  как  IDC_ARROW с погрешностью на  Hotspot (т.е. он действительно создается). При этом (см. блок (2)) на самом битмапе отрисовано то, что хотелось бы получить, маска битмапа тоже верна.


Grig ©   (16.07.20 16:12[1]

hbmMask и hbmColor надо все-таки делать немного иначе:

hbmMask
Устанавливает битовую маску точечного рисунка значка. Если эта структура определяет черно-белый значок, то эта битовая маска форматируется так, чтобы верхняя половина была битовая маска AND значка, а нижняя половина - битовая маска XOR значка. При этом условии, высота должна быть равняться умноженной на два. Если эта структура определяет цветной значок, то эта маска определяет только битовую маску AND значка.

hbmColor
Дескриптор цветного точечного рисунка значка. Этот член структуры может быть дополнительным, если эта структура определяет черно-белый значок. Битовая маска AND параметра hbmMask применяется с флажком SRCAND в месте назначения; позже, цветной точечный рисунок применяется (использующий XOR) в месте назначения при помощи использования флажка SRCINVERT.


Самый простой способ через ImageList:

function TDragToolButtonObject.CreateDragCursor(Bitmap: TBitmap;
 Hotspot: TPoint; MaskColor: TColor): HCURSOR;
var
 ImageList: TImageList;
 ColorBitmap, MaskBitmap: TBitmap;
 IconInfo: TIconInfo;
begin
 ImageList := TImageList.Create(nil);
 try
   ImageList.BlendColor := MaskColor;
   ImageList.Width := Bitmap.Width;
   ImageList.Height := Bitmap.Height;
   ImageList.AddMasked(Bitmap, MaskColor);

   ColorBitmap := TBitmap.Create;
   try
     ColorBitmap.Canvas.Brush.Color := clBlack;
     ColorBitmap.SetSize(Bitmap.Width, Bitmap.Height);

     MaskBitmap := TBitmap.Create;
     try
       MaskBitmap.Canvas.Brush.Color := clWhite;
       MaskBitmap.SetSize(Bitmap.Width, Bitmap.Height);

       ImageList.Draw(ColorBitmap.Canvas, 0, 0, 0, dsNormal, itImage);
       ImageList.Draw(MaskBitmap.Canvas, 0, 0, 0, dsNormal, itMask);

       with IconInfo do
       begin
         fIcon := False;
         xHotspot := Hotspot.X;
         yHotspot := Hotspot.Y;
         hbmMask := MaskBitmap.Handle;
         hbmColor := ColorBitmap.Handle;
       end;

       Result := CreateIconIndirect(IconInfo);
     finally
       MaskBitmap.Free;
     end;
   finally
     ColorBitmap.Free;
   end;
 finally
   ImageList.Free;
 end;
end;


От наложения системного курсора отказался, отрисовываю вручную. Проблема там в том, что если курсор полупрозрачный, то при его отрисовке на bitmap-е полупрозрачные пиксели смешиваются с цветом фона bitmap-а и маской их, понятно, уже не отбросить. Заморачиваться с этим не стал.


http://forum.delphimaster.net/cgi-bin/forum.pl?id=1594275870&n=7