Pintura TPaintBox durante Drag & Drop con DragImage

Question

En mi aplicación (Delphi 2007) Quiero arrastrar elementos de un ListView a un PaintBox y poner de relieve las áreas correspondientes en el controlador de OnPaint del PaintBox. Sin embargo siempre consigo artefactos feas. ¿Tiene algún consejo de cómo puedo deshacerme de ellos?

Proyecto de prueba: Basta con crear una nueva aplicación VCL y reemplace el código en Unit1.pas con lo siguiente. A continuación, iniciar los elementos de la lista de aplicaciones y arrastre sobre el rectángulo en el 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.

Editar Aquí está una imagen de la falla: DragImage artefacto http://img269.imageshack.us/img269/6535/15778780.png

Espero ver el rectángulo azul completo con borde grueso. Sin embargo, la imagen de arrastre por debajo se puede ver el rectángulo-un resaltado.

Editar 2: Este sitio habla de "Cuestiones de Pintura":

  

El SDK ImageList señala que cuando   dibujar la imagen de arrastre se puede llegar   problemas con actualizaciones o pintura pantalla   a menos que utilice el ImageList_DragLeave   función de la API para ocultar la imagen de arrastre   mientras que se produce la pintura (que es   lo que el método en el HideDragImage   clase hace). Por desgracia, si   no poseen el control que se está   pintada haciendo esto no es realmente una   opción.

No tengo el problema mencionado en la última frase. Sin embargo yo no era capaz de encontrar el lugar correcto y la lista de imágenes a la derecha (que es no ImageList1 en mi proyecto de prueba - probablemente ListView1.GetDragImages). Llamar ImageList_DragLeave

Answer 1

La clave es ocultar la imagen de arrastre antes de que el cuadro de pintura se vuelve a dibujar, y para mostrar de nuevo después de eso. Si reemplaza este código en tu pregunta:

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;

con este

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;

debería funcionar. Bueno, lo hace para mí con Delphi 2007 en Windows XP de 64 bits.

Y felicitaciones para el código de demostración en su pregunta, una excelente manera de dejar a ver el problema.

Answer 2

Probado en XP, Delphi 2010 - consigo los artefactos, por lo que es relacionado con XP y no se fija en D2010

Editar:

Tras realizar investigaciones adicionales - si arrastra un icono para que el ratón solamente solo entra en la caja (pero el icono no lo hace), entonces el cuadro se dibuja correctamente, es sólo cuando el icono entra en la caja de pinturas que se producen los artefactos.

He añadido código de modo que si el estado era dsDragMove entonces sería forzar un repintado y esto funcionó, pero sufría de parpadeo