delphi - 在拖放过程中使用 DragImage 绘制 TPaintBox

Question

在我的应用程序(Delphi 2007)中，我想将项目从 ListView 拖动到 PaintBox 并突出显示 PaintBox 的 OnPaint 处理程序中的相应区域。然而我总是得到丑陋的文物。你对我如何摆脱它们有什么建议吗？

测试项目:只需创建一个新的 VCL 应用程序并将 Unit1.pas 中的代码替换为以下内容。然后启动应用程序并将列表项拖到 PaintBox 中的矩形上。

unit Unit1;

interface

uses
  Windows,
  Messages,
  SysUtils,
  Variants,
  Classes,
  Graphics,
  Controls,
  Forms,
  Dialogs,
  ExtCtrls,
  ComCtrls,
  ImgList;

type
  TForm1 = class(TForm)
  private
    PaintBox1: TPaintBox;
    ListView1: TListView;
    ImageList1: TImageList;
    FRectIsHot: Boolean;
    function GetSensitiveRect: TRect;
    procedure PaintBox1DragOver(Sender, Source: TObject; X, Y: Integer;
      State: TDragState; var Accept: Boolean);
    procedure PaintBox1Paint(Sender: TObject);
  public
    constructor Create(AOwner: TComponent); override;
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

uses
  TypInfo;

const
  IconIDs: array[TMsgDlgType] of PChar = (IDI_EXCLAMATION, IDI_HAND,
    IDI_ASTERISK, IDI_QUESTION, nil);

{ TForm1 }

constructor TForm1.Create(AOwner: TComponent);
var
  Panel1: TPanel;
  mt: TMsgDlgType;
  Icon: TIcon;
  li: TListItem;
begin
  inherited Create(AOwner);
  Width := 600;
  Height := 400;

  ImageList1 := TImageList.Create(Self);
  ImageList1.Name := 'ImageList1';
  ImageList1.Height := 32;
  ImageList1.Width := 32;

  ListView1 := TListView.Create(Self);
  ListView1.Name := 'ListView1';
  ListView1.Align := alLeft;
  ListView1.DragMode := dmAutomatic;
  ListView1.LargeImages := ImageList1;

  Panel1 := TPanel.Create(Self);
  Panel1.Name := 'Panel1';
  Panel1.Caption := 'Drag list items here';
  Panel1.Align := alClient;

  PaintBox1 := TPaintBox.Create(Self);
  PaintBox1.Name := 'PaintBox1';
  PaintBox1.Align := alClient;
  PaintBox1.ControlStyle := PaintBox1.ControlStyle + [csDisplayDragImage];
  PaintBox1.OnDragOver := PaintBox1DragOver;
  PaintBox1.OnPaint := PaintBox1Paint;
  PaintBox1.Parent := Panel1;

  ListView1.Parent := Self;
  Panel1.Parent := Self;

  Icon := TIcon.Create;
  try
    for mt := Low(TMsgDlgType) to High(TMsgDlgType) do
      if Assigned(IconIDs[mt]) then
      begin
        li := ListView1.Items.Add;
        li.Caption := GetEnumName(TypeInfo(TMsgDlgType), Ord(mt));
        Icon.Handle := LoadIcon(0, IconIDs[mt]);
        li.ImageIndex := ImageList1.AddIcon(Icon);
      end;
  finally
    Icon.Free;
  end;
end;

function TForm1.GetSensitiveRect: TRect;
begin
  Result := PaintBox1.ClientRect;
  InflateRect(Result, -PaintBox1.Width div 4, -PaintBox1.Height div 4);
end;

procedure TForm1.PaintBox1Paint(Sender: TObject);
var
  r: TRect;
begin
  r := GetSensitiveRect;
  if FRectIsHot then
  begin
    PaintBox1.Canvas.Pen.Width := 5;
    PaintBox1.Canvas.Brush.Style := bsSolid;
    PaintBox1.Canvas.Brush.Color := clAqua;
  end
  else
  begin
    PaintBox1.Canvas.Pen.Width := 1;
    PaintBox1.Canvas.Brush.Style := bsClear;
  end;
  PaintBox1.Canvas.Rectangle(r.Left, r.Top, r.Right, r.Bottom);
end;

procedure TForm1.PaintBox1DragOver(Sender, Source: TObject; X,
  Y: Integer; State: TDragState; var Accept: Boolean);
var
  r: TRect;
  MustRepaint: Boolean;
begin
  MustRepaint := False;

  if State = dsDragEnter then
  begin
    FRectIsHot := False;
    MustRepaint := True;
  end
  else
  begin
    r := GetSensitiveRect;
    Accept := PtInRect(r, Point(X, Y));

    if Accept <> FRectIsHot then
    begin
      FRectIsHot := Accept;
      MustRepaint := True;
    end;
  end;

  if MustRepaint then
    PaintBox1.Invalidate;
end;

end.

编辑:这是该故障的图片:DragImage artefact http://img269.imageshack.us/img269/6535/15778780.png

我希望看到带有粗边框的完整蓝色矩形。然而，在拖动图像下方，我们可以看到未突出显示的矩形。

编辑 2: This site谈论“绘画问题”:

The ImageList SDK notes that when drawing the drag image you can get issues with updates or screen painting unless you use the ImageList_DragLeave API function to hide the drag image whilst the painting occurs (which is what the HideDragImage method in the class does). Unfortunately, if you don't own the control that's being painted doing this isn't really an option.

我没有遇到最后一句提到的问题。尽管如此，我无法找到正确的位置和正确的图像列表(它不是我的测试项目中的ImageList1 - 可能是ListView1.GetDragImages)来调用ImageList_DragLeave。

Answer 1

关键是在重绘绘画框之前隐藏拖动图像，并在重绘之后再次显示它。如果您在问题中替换此代码:

procedure TForm1.PaintBox1DragOver(Sender, Source: TObject; X,
  Y: Integer; State: TDragState; var Accept: Boolean);
var
  r: TRect;
  MustRepaint: Boolean;
begin
  MustRepaint := False;

  if State = dsDragEnter then
  begin
    FRectIsHot := False;
    MustRepaint := True;
  end
  else
  begin
    r := GetSensitiveRect;
    Accept := PtInRect(r, Point(X, Y));

    if Accept <> FRectIsHot then
    begin
      FRectIsHot := Accept;
      MustRepaint := True;
    end;
  end;

  if MustRepaint then
    PaintBox1.Invalidate;
end;

有了这个

procedure TForm1.PaintBox1DragOver(Sender, Source: TObject; X,
  Y: Integer; State: TDragState; var Accept: Boolean);
var
  r: TRect;
begin
  if State = dsDragEnter then
  begin
    FRectIsHot := False;
    PaintBox1.Invalidate;
  end
  else
  begin
    r := GetSensitiveRect;
    Accept := PtInRect(r, Point(X, Y));

    if Accept <> FRectIsHot then
    begin
      FRectIsHot := Accept;
      ImageList_DragShowNolock(False);
      try
        PaintBox1.Refresh;
      finally
        ImageList_DragShowNolock(True);
      end;
    end;
  end;
end;

它应该可以工作。嗯，对于我在 Windows XP 64 位上使用 Delphi 2007 来说确实如此。

感谢您问题中的演示代码，这是让我们了解问题的好方法。