TPaintBox während Drag&Drop mit DragImage bemalen

Question

In meiner Anwendung (Delphi 2007) möchte ich Elemente aus einer ListView in eine PaintBox ziehen und entsprechende Bereiche im OnPaint-Handler der PaintBox hervorheben. Allerdings bekomme ich immer hässliche Artefakte. Haben Sie einen Rat, wie ich sie loswerden kann?

Projekt testen: Erstellen Sie einfach eine neue VCL-Anwendung und ersetzen Sie den Code in Unit1.pas durch den folgenden. Starten Sie dann die Anwendung und ziehen Sie Listenelemente über das Rechteck in der 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.

Bearbeiten: Hier ist ein Bild der Störung: Artefakt DragImage http://img269.imageshack.us/img269/6535/15778780.png

Ich erwarte das komplette blaue Rechteck mit dickem Rand. Unter dem Ziehbild kann man jedoch das nicht hervorgehobene Rechteck sehen.

Bearbeiten 2: Diese Seite spricht über "Malereiprobleme":

Das ImageList SDK stellt fest, dass, wenn Ziehen des Bildes kann es zu Probleme mit Aktualisierungen oder Bildschirmdarstellungen es sei denn, Sie verwenden die ImageList_DragLeave API-Funktion zum Ausblenden des Ziehbildes verwenden auszublenden, während das Bild gezeichnet wird (was die was die Methode HideDragImage in der Klasse Klasse tut). Leider, wenn Sie das gemalte Steuerelement nicht besitzen gemalt wird, ist dies nicht wirklich eine Möglichkeit.

Ich habe das im letzten Satz erwähnte Problem nicht. Trotzdem war ich nicht in der Lage, den richtigen Ort und die richtige Bildliste zu finden (es ist no ImageList1 in meinem Testprojekt - wahrscheinlich ListView1.GetDragImages), um ImageList_DragLeave aufzurufen.

Answer 1

Der Schlüssel liegt darin, das Schleppbild auszublenden, bevor der Farbkasten neu gezeichnet wird, und es danach wieder einzublenden. Wenn Sie diesen Code in Ihrer Frage ersetzen:

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;

mit diesem

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;

sollte es funktionieren. Nun, bei mir funktioniert es mit Delphi 2007 unter Windows XP 64 bit.

Und ein großes Lob für den Demonstrationscode in Ihrer Frage, eine ausgezeichnete Möglichkeit, uns das Problem zu zeigen.

Answer 2

Getestet auf XP, Delphi 2010 - ich erhalte die Artefakte, also ist es XP bezogen und nicht in D2010 behoben

Bearbeiten:

Nach weiterer Untersuchung - wenn Sie ein Symbol ziehen, so dass die Maus nur gerade in den Kasten eintritt (aber das Symbol nicht), dann wird der Kasten richtig gezeichnet, es ist nur, wenn das Symbol in den Malkasten, dass die Artefakte auftreten.

Ich fügte Code hinzu, so dass, wenn der Zustand dsDragMove war, dann würde es eine Neuzeichnung erzwingen und dies funktionierte, aber von Flimmern gelitten