Why does custom cursor image show up incorrect?

Question

Background

I have written a function, which creates a custom cursor, based on the bitmap associated with a given Device Context. I use this to create drag-and-drop cursors that appear as "tear-offs" - a bit like they are used in "Trello".

I've been using the function for a while without problems, but when I use it with a new tree component I'm working on it started creating partially blank cursors.

I have verified that the problem occur both in Delphi 2010 and Delphi Berlin, and I have also verified that it's broken both in Windows 7 and Windows 10.

Here is a photo that shows what the cursor should look like (Sorry - couldn't find a quick way to screen-grab a cursor):

And here is what it looks like when it's partially blank (well, it's more than partially blank - it's practically invisible):

Troubleshooting

After troubleshooting I've found, that if a PNG-image is written to the bitmap associated with the DC before a call to GetDragCursor, the cursor is messed up.

Here is the simplest code I can think of that demonstrate the problem:

A form with two TPaintBox components: MyPaintBoxWorks and MyPaintBoxBroken.

• When you click on MyPaintBoxWorks, you get the expected cursor.
• When you click on MyPaintBoxBroken you just get the png-image.

In the name of making it easy to read (I hope), I've excluded all error- and resource-handling. This has no impact on the problem. In order for it to work, you need to have access to a Png-image. Any png-image will do. Then update the code to load your image instead.

uses
  Types,
  pngimage;

//////////////////////////////////////////////////////////////////////
procedure TMyForm.FormPaint(Sender: TObject);
begin
  MyPaintBoxWorks.Canvas.Brush.Color := clGreen;
  MyPaintBoxWorks.Canvas.Rectangle( 0, 0,
                                    MyPaintBoxWorks.Width, MyPaintBoxWorks.Height );
  MyPaintBoxBroken.Canvas.Brush.Color := clRed;
  MyPaintBoxBroken.Canvas.Rectangle( 0, 0,
                                     MyPaintBoxBroken.Width, MyPaintBoxBroken.Height );
end;

function GetDragCursor( Handle: HDC;
                        Width, Height: integer;
                        CursorX, CursorY: integer ): TCursor; forward;


//////////////////////////////////////////////////////////////////////
procedure TMyForm.MyPaintBoxWorksMouseDown( Sender: TObject;
                                            Button: TMouseButton;
                                            Shift: TShiftState;
                                            X, Y: Integer);
begin
  Screen.Cursor := GetDragCursor( MyPaintBoxWorks.Canvas.Handle,
                                  MyPaintBoxWorks.Width, MyPaintBoxWorks.Height,
                                  X, Y );
end;


//////////////////////////////////////////////////////////////////////
procedure TMyForm.MyPaintBoxBrokenMouseDown( Sender: TObject;
                                             Button: TMouseButton;
                                             Shift: TShiftState;
                                             X, Y: Integer );
var
  Img: TPngImage;

begin
  Img := TPngImage.Create;
  Img.LoadFromFile( 'D:\TestImage.png' );
  Img.Draw( MyPaintBoxBroken.Canvas, Rect( 20, 20, 40, 40 ) );
  Screen.Cursor := GetDragCursor( MyPaintBoxBroken.Canvas.Handle,
                                  MyPaintBoxBroken.Width, MyPaintBoxBroken.Height,
                                  X, Y );
end;


//////////////////////////////////////////////////////////////////////
function GetDragCursor( Handle: HDC;
                        Width, Height: integer;
                        CursorX, CursorY: integer ): TCursor;
var
  MaskDC           : HDC;
  OrgMaskBmp       : HBITMAP;
  MaskBmp          : HBITMAP;
  ColourDC         : HDC;
  OrgColourBmp     : HBITMAP;
  ColourBmp        : HBITMAP;
  IconInfo         : TIconInfo;
  Brush            : HBRUSH;

begin
  // Create Colour bitmap
  // ====================
  ColourDC := CreateCompatibleDC( Handle );
  ColourBmp := CreateCompatibleBitmap( Handle, Width, Height );
  OrgColourBmp := SelectObject( ColourDC, ColourBmp );

  BitBlt( ColourDC, 0, 0, Width, Height, Handle, 0, 0, SRCCOPY );

  SelectObject( ColourDC, OrgColourBmp );

  // Create Mask bitmap
  // ==================
  MaskDC := CreateCompatibleDC( Handle );
  MaskBmp := CreateCompatibleBitmap( Handle, Width, Height );
  OrgMaskBmp := SelectObject( MaskDC, MaskBmp );

  // Fill with white
  Brush := CreateSolidBrush( $FFFFFF );
  FillRect( MaskDC, Rect( 0, 0, Width, Height ), Brush );
  DeleteObject( Brush );

  // Fill masked area with black
  Brush := CreateSolidBrush( $000000 );
  FillRect( MaskDC, Rect( 0, 0, Width, Height ), Brush );
  DeleteObject( Brush );

  SelectObject( MaskDC, OrgMaskBmp );

  // Create and set cursor
  // =====================
  with iconInfo do
  begin
    fIcon :=    FALSE;
    xHotspot := CursorX;
    yHotspot := CursorY;
    hbmMask :=  MaskBmp;
    hbmColor := ColourBmp;
  end;
  Screen.Cursors[1] := CreateIconIndirect( iconInfo );
  Result := 1;
end;

I have studied the function and Microsofts documentation at length, and I cannot find anything wrong with the function.

I have also studied TPngImage.Draw and cannot see anything obvious wrong with it (I shouldn't hope so). The function:

• Calls TPngImage.DrawPartialTrans, which in turn
• Creates a bitmap via CreateDIBSection
• Scans through the pixels and computes alpha-blended RGB values
• Use pointer-arithmetics to move through the pixel-buffer
• Makes a call to BitBlt to copy the final image into the DC

(I've included the code for the function at the end of the question for reference)

The cursors are always generated correctly if I:

• Comment out the code that writes to the pixel-buffer, or
• Only scan the first couple of rows in the image, or
• Comment out the final call to BitBlt

This looks like a buffer-overrun, but there is nothing in the code that seems to support this. Also, it's more likely that it is my code that is at fault.

Question

Is there anything in either my function GetDragCursor or DrawPartialTrans that is wrong or looks suspicious?

procedure TPngImage.DrawPartialTrans(DC: HDC; Rect: TRect);
  {Adjust the rectangle structure}
  procedure AdjustRect(var Rect: TRect);
  var
    t: Integer;
  begin
    if Rect.Right < Rect.Left then
    begin
      t := Rect.Right;
      Rect.Right := Rect.Left;
      Rect.Left := t;
    end;
    if Rect.Bottom < Rect.Top then
    begin
      t := Rect.Bottom;
      Rect.Bottom := Rect.Top;
      Rect.Top := t;
    end
  end;

type
  {Access to pixels}
  TPixelLine = Array[Word] of TRGBQuad;
  pPixelLine = ^TPixelLine;
const
  {Structure used to create the bitmap}
  BitmapInfoHeader: TBitmapInfoHeader =
    (biSize: sizeof(TBitmapInfoHeader);
     biWidth: 100;
     biHeight: 100;
     biPlanes: 1;
     biBitCount: 32;
     biCompression: BI_RGB;
     biSizeImage: 0;
     biXPelsPerMeter: 0;
     biYPelsPerMeter: 0;
     biClrUsed: 0;
     biClrImportant: 0);
var
  {Buffer bitmap creation}
  BitmapInfo  : TBitmapInfo;
  BufferDC    : HDC;
  BufferBits  : Pointer;
  OldBitmap,
  BufferBitmap: HBitmap;
  Header: TChunkIHDR;

  {Transparency/palette chunks}
  TransparencyChunk: TChunktRNS;
  PaletteChunk: TChunkPLTE;
  TransValue, PaletteIndex: Byte;
  CurBit: Integer;
  Data: PByte;

  {Buffer bitmap modification}
  BytesPerRowDest,
  BytesPerRowSrc,
  BytesPerRowAlpha: Integer;
  ImageSource, ImageSourceOrg,
  AlphaSource     : pByteArray;
  ImageData       : pPixelLine;
  i, j, i2, j2    : Integer;

  {For bitmap stretching}
  W, H            : Cardinal;
  Stretch         : Boolean;
  FactorX, FactorY: Double;

begin
  {Prepares the rectangle structure to stretch draw}
  if (Rect.Right = Rect.Left) or (Rect.Bottom = Rect.Top) then exit;
  AdjustRect(Rect);
  {Gets the width and height}
  W := Rect.Right - Rect.Left;
  H := Rect.Bottom - Rect.Top;
  Header := Self.Header; {Fast access to header}
  Stretch := (W <> Header.Width) or (H <> Header.Height);
  if Stretch then FactorX := W / Header.Width else FactorX := 1;
  if Stretch then FactorY := H / Header.Height else FactorY := 1;

  {Prepare to create the bitmap}
  Fillchar(BitmapInfo, sizeof(BitmapInfo), #0);
  BitmapInfoHeader.biWidth := W;
  BitmapInfoHeader.biHeight := -Integer(H);
  BitmapInfo.bmiHeader := BitmapInfoHeader;

  {Create the bitmap which will receive the background, the applied}
  {alpha blending and then will be painted on the background}
  BufferDC := CreateCompatibleDC(0);
  {In case BufferDC could not be created}
  if (BufferDC = 0) then RaiseError(EPNGOutMemory, EPNGOutMemoryText);
  BufferBitmap := CreateDIBSection(BufferDC, BitmapInfo, DIB_RGB_COLORS, BufferBits, 0, 0);
  {In case buffer bitmap could not be created}
  if (BufferBitmap = 0) or (BufferBits = Nil) then
  begin
    if BufferBitmap <> 0 then DeleteObject(BufferBitmap);
    DeleteDC(BufferDC);
    RaiseError(EPNGOutMemory, EPNGOutMemoryText);
  end;

  {Selects new bitmap and release old bitmap}
  OldBitmap := SelectObject(BufferDC, BufferBitmap);

  {Draws the background on the buffer image}
  BitBlt(BufferDC, 0, 0, W, H, DC, Rect.Left, Rect.Top, SRCCOPY);

  {Obtain number of bytes for each row}
  BytesPerRowAlpha := Header.Width;
  BytesPerRowDest := (((BitmapInfo.bmiHeader.biBitCount * W) + 31)
    and not 31) div 8; {Number of bytes for each image row in destination}
  BytesPerRowSrc := (((Header.BitmapInfo.bmiHeader.biBitCount * Header.Width) +
    31) and not 31) div 8; {Number of bytes for each image row in source}

  {Obtains image pointers}
  ImageData := BufferBits;
  AlphaSource := Header.ImageAlpha;
  Longint(ImageSource) := Longint(Header.ImageData) +
    Header.BytesPerRow * Longint(Header.Height - 1);
  ImageSourceOrg := ImageSource;

  case Header.BitmapInfo.bmiHeader.biBitCount of
    {R, G, B images}
    24:
      FOR j := 1 TO H DO
      begin
        {Process all the pixels in this line}
        FOR i := 0 TO W - 1 DO
        begin
          if Stretch then i2 := trunc(i / FactorX) else i2 := i;
          {Optmize when we don´t have transparency}
          if (AlphaSource[i2] <> 0) then
            if (AlphaSource[i2] = 255) then
            begin
              pRGBTriple(@ImageData[i])^ := pRGBTriple(@ImageSource[i2 * 3])^;
              ImageData[i].rgbReserved := 255;
            end
            else
              with ImageData[i] do
              begin
                rgbRed := ($7F + ImageSource[2+i2*3] * AlphaSource[i2] + rgbRed *
                  (not AlphaSource[i2])) div $FF;
                rgbGreen := ($7F + ImageSource[1+i2*3] * AlphaSource[i2] +
                  rgbGreen * (not AlphaSource[i2])) div $FF;
                rgbBlue := ($7F + ImageSource[i2*3] * AlphaSource[i2] + rgbBlue *
                 (not AlphaSource[i2])) div $FF;
                rgbReserved := not (($7F + (not rgbReserved) * (not AlphaSource[i2])) div $FF);
            end;
          end;

        {Move pointers}
        inc(Longint(ImageData), BytesPerRowDest);
        if Stretch then j2 := trunc(j / FactorY) else j2 := j;
        Longint(ImageSource) := Longint(ImageSourceOrg) - BytesPerRowSrc * j2;
        Longint(AlphaSource) := Longint(Header.ImageAlpha) +
          BytesPerRowAlpha * j2;
      end;
    {Palette images with 1 byte for each pixel}
    1,4,8: if Header.ColorType = COLOR_GRAYSCALEALPHA then
      FOR j := 1 TO H DO
      begin
        {Process all the pixels in this line}
        FOR i := 0 TO W - 1 DO
          with ImageData[i], Header.BitmapInfo do begin
            if Stretch then i2 := trunc(i / FactorX) else i2 := i;
            rgbRed := ($7F + ImageSource[i2] * AlphaSource[i2] +
              rgbRed * (not AlphaSource[i2])) div $FF;
            rgbGreen := ($7F + ImageSource[i2] * AlphaSource[i2] +
              rgbGreen * (not AlphaSource[i2])) div $FF;
            rgbBlue := ($7F + ImageSource[i2] * AlphaSource[i2] +
              rgbBlue * (not AlphaSource[i2])) div $FF;
            rgbReserved := not (($7F + (not rgbReserved) * (not AlphaSource[i2])) div $FF);
          end;

        {Move pointers}
        Longint(ImageData) := Longint(ImageData) + BytesPerRowDest;
        if Stretch then j2 := trunc(j / FactorY) else j2 := j;
        Longint(ImageSource) := Longint(ImageSourceOrg) - BytesPerRowSrc * j2;
        Longint(AlphaSource) := Longint(Header.ImageAlpha) +
          BytesPerRowAlpha * j2;
      end
    else {Palette images}
    begin
      {Obtain pointer to the transparency chunk}
      TransparencyChunk := TChunktRNS(Chunks.ItemFromClass(TChunktRNS));
      PaletteChunk := TChunkPLTE(Chunks.ItemFromClass(TChunkPLTE));

      FOR j := 1 TO H DO
      begin
        {Process all the pixels in this line}
        i := 0;
        repeat
          CurBit := 0;
          if Stretch then i2 := trunc(i / FactorX) else i2 := i;
          Data := @ImageSource[i2];

          repeat
            {Obtains the palette index}
            case Header.BitDepth of
              1: PaletteIndex := (Data^ shr (7-(I Mod 8))) and 1;
            2,4: PaletteIndex := (Data^ shr ((1-(I Mod 2))*4)) and $0F;
             else PaletteIndex := Data^;
            end;

            {Updates the image with the new pixel}
            with ImageData[i] do
            begin
              TransValue := TransparencyChunk.PaletteValues[PaletteIndex];
              rgbRed := (255 + PaletteChunk.Item[PaletteIndex].rgbRed *
                 TransValue + rgbRed * (255 - TransValue)) shr 8;
              rgbGreen := (255 + PaletteChunk.Item[PaletteIndex].rgbGreen *
                 TransValue + rgbGreen * (255 - TransValue)) shr 8;
              rgbBlue := (255 + PaletteChunk.Item[PaletteIndex].rgbBlue *
                 TransValue + rgbBlue * (255 - TransValue)) shr 8;
            end;

            {Move to next data}
            inc(i); inc(CurBit, Header.BitmapInfo.bmiHeader.biBitCount);
          until CurBit >= 8;
          {Move to next source data}
          //inc(Data);
        until i >= Integer(W);

        {Move pointers}
        Longint(ImageData) := Longint(ImageData) + BytesPerRowDest;
        if Stretch then j2 := trunc(j / FactorY) else j2 := j;
        Longint(ImageSource) := Longint(ImageSourceOrg) - BytesPerRowSrc * j2;
      end
    end {Palette images}
  end {case Header.BitmapInfo.bmiHeader.biBitCount};

  {Draws the new bitmap on the foreground}
  BitBlt(DC, Rect.Left, Rect.Top, W, H, BufferDC, 0, 0, SRCCOPY);

  {Free bitmap}
  SelectObject(BufferDC, OldBitmap);
  DeleteObject(BufferBitmap);
  DeleteDC(BufferDC);
end;

Answer 1

I was able to make it work with GDI+.
Seems like the Delphi png draw does not paint well on a transparent 32bit Bitmap. (* see EDIT)

Your GetDragCursor worked well for me.

I used a TPaintBox with height of 16. and loaded a PNG with size of 32x32. and used a 32bit off-screen bitmap to create the cursor.

uses GDIPOBJ, GDIPAPI;

procedure TForm1.FormCreate(Sender: TObject);
begin
  PaintBox1.Height := 16;
end;

procedure TForm1.PaintBox1Paint(Sender: TObject);
begin
  PaintBox1.Canvas.Brush.Color := clRed;
  PaintBox1.Canvas.Rectangle(0, 0, PaintBox1.Width, PaintBox1.Height );
end;

procedure GPDrawImageOver(Image: TGPImage; dc: HDC; X, Y: Integer);
var
  Graphics: TGPGraphics;
begin
  Graphics := TGPGraphics.Create(dc);
  try
    Graphics.SetCompositingMode(CompositingModeSourceOver);
    Graphics.DrawImage(Image, X, Y, Image.GetWidth, Image.GetHeight);
  finally
    Graphics.Free;
  end;
end;

procedure TForm1.PaintBox1MouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
var
  Bmp: TBitmap;
  Png: TGPImage;
  x1, y1: Integer;
  px: PRGBQuad;
begin
  Bmp := TBitmap.Create;
  try
    Png := TGPImage.Create('C:\Users\Kobik\Downloads\Internet Explorer.png');
    try

      Bmp.Width := PaintBox1.Width;
      Bmp.Height := Png.GetHeight;
      Bmp.PixelFormat := pf32bit;
      Bmp.HandleType := bmDIB;
      Bmp.IgnorePalette := True;

      // paint PaintBox1 canvas on the bitmap
      BitBlt(Bmp.Canvas.Handle, 0, 0, PaintBox1.Width, PaintBox1.Height,
        PaintBox1.Canvas.Handle, 0, 0, SRCCOPY);

      // make the bottom bitmap part transparent
      for y1 := 0 to Bmp.Height - 1 do
      begin
        px := Bmp.ScanLine[y1];
        for x1 := 0 to Bmp.Width - 1 do
        begin
          if y1 < PaintBox1.Height then
            px.rgbReserved := 255 // opaque
          else
            px.rgbReserved := 0;  // fully transparent
          Inc(px);
        end;
      end;

      // draw png over the bitmap
      GPDrawImageOver(Png, Bmp.Canvas.Handle, 0, 0);
    finally
      Png.Free;
    end;

    Screen.Cursor := GetDragCursor(Bmp.Canvas.Handle,
      Bmp.Width, Bmp.Height, X, Y);
  finally
    Bmp.Free;
  end;
end;

The result bitmap looks like this (where the bottom part is fully transparent):

---

EDIT: The GDI+ is actually not needed (My initial answer was based with Delphi 7 in which DrawPartialTrans is not accurate) .

In newer Delphi versions the TPngImage.DrawPartialTrans works just fine from the little tests I have made.

However, preparing and using the off-screen Bitmap like I did, is the correct way to go.
You can use the same code above, but instead of using a TGPImage simply use a TPngImage.