Background
I wrote a function that creates a custom cursor based on the bitmap associated with this Device Context. I use this to create drag and drop cursors that appear as “snippets” - a bit like they are used in “Trello”.
I used this function for a while without any problems, but when I use it with the new tree component I'm working on, it started to create partially empty cursors.
I checked that the problem occurs in both Delphi 2010 and Delphi Berlin , and I also checked that it broke in both Windows 7 > and Windows 10 .
Here is a photo that shows how the cursor should look (Sorry - could not find a quick way to capture the screen with the cursor):
And this is how it looks when it is partially empty (well, it is more than partially empty - it is practically invisible):
Troubleshooting
After troubleshooting, I found that if the PNG image is written to the bitmap associated with the DC before , by calling GetDragCursor, the cursor is messed up.
Here is the simplest code I can imagine demonstrating 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 a png image.
In the name of simplification of reading (I hope), I excluded all error and resource handling. This does not affect the problem. For it to work, you need to have access to the Png image. Any png image will do. Then update the code to upload the image.
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 Microsoft documentation and documentation in detail, and I cannot find anything wrong with this feature.
I also studied TPngImage.Draw and don't see anything obvious about it (I don't hope). Function:
- Calls TPngImage.DrawPartialTrans, which in turn
- Creates a bitmap via CreateDIBSection
- Scans pixels and calculates RGB values with alpha blending.
- Use arithmetic pointer to move around the pixel buffer
- Makes a BitBlt call to copy the final image to DC
(I included the code for the function at the end of the question for reference)
Cursors are always generated correctly if I:
- Comment on the code that is written to the pixel buffer, or
- Check only the first couple of lines in the image or
- Comment on the final BitBlt challenge
It looks like a buffer overflow, but there is nothing in the code that seems to support this. Also, it is more likely that this is my code that is to blame.
Question
Is there anything in my GetDragCursor or DrawPartialTrans function that is incorrect 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),