Question

背景

我编写了一个函数，它根据与给定设备上下文关联的位图创建自定义光标。我使用它来创建拖放游标，这些游标显示为＆＃34;撕掉＆＃34; - 有点像他们用在＆＃34; Trello＆＃34;。

我已经使用该功能一段时间没有问题，但是当我使用新的树组件时，我正在开始创建部分空白的游标。 < / p>

我已经确认问题出现在 Delphi 2010 和 Delphi Berlin 中，并且我还验证了它在 Windows中都被破坏了7 和 Windows 10 。

这是一张显示光标应该是什么样子的照片（抱歉 - 找不到快速浏览光标的方法）：

这就是它部分空白时的样子（好吧，它不仅仅是部分空白 - 它实际上是看不见的）：

疑难解答

我经过排查后发现，如果在调用GetDragCursor之前将PNG图像写入与DC 关联的位图，则光标会混乱。

以下是我能想到的最简单的代码，用于演示问题：

包含两个TPaintBox组件的表单： MyPaintBoxWorks 和 MyPaintBoxBroken 。

当您单击MyPaintBoxWorks时，您将获得预期的光标。
当您点击MyPaintBoxBroken时，您只需获取png-image。

为了使其易于阅读（我希望），我已经排除了所有错误和资源处理。这对问题没有影响。为了使其工作，您需要访问Png图像。任何png图像都可以。然后更新代码以加载图片。

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;

我已经详细研究了函数和微软文档，我发现函数没有任何问题。

我还研究过TPngImage.Draw并且看不出任何明显的错误（我不应该这么做）。功能：

调用TPngImage.DrawPartialTrans，后者依次为
通过CreateDIBSection
扫描像素并计算alpha混合RGB值
使用指针算术来移动像素缓冲区
调用BitBlt将最终图像复制到DC

（我已在问题末尾包含该功能的代码供参考）

如果我：

，总是正确生成游标

注释掉写入像素缓冲区的代码，或
仅扫描图像中的前几行，或
评论对BitBlt的最终调用

这看起来像缓冲区溢出，但代码中没有任何东西似乎支持这一点。此外，它更可能是我的代码有问题。

问题

我的函数 GetDragCursor 或 DrawPartialTrans 中是否存在任何错误或看起来可疑的内容？

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

我能够使它与GDI +一起使用。
好像Delphi png draw在透明的32位Bitmap上绘制得不好。（* 参见编辑）

你的GetDragCursor对我有用。

我使用了高度为16的TPaintBox并加载了大小为32x32的PNG。并使用32位屏幕外位图来创建光标。

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;

结果位图看起来像这样（底部是完全透明的）：

编辑： GDI +实际上不需要（我的初步答案基于Delphi 7，其中DrawPartialTrans不准确）。

在较新的Delphi版本中，TPngImage.DrawPartialTrans从我做过的小测试中就可以正常工作。

然而，像我一样准备和使用离屏位图是正确的方法您可以使用上面相同的代码，但不要使用TGPImage，而只需使用TPngImage。

为什么自定义光标图像显示不正确？

1 个答案: