Peinture TPaintBox lors de Drag & Drop avec dragImage

Question

Dans ma demande (Delphi 2007) Je veux faire glisser des éléments d'un ListView à un PaintBox et mettre en évidence les zones correspondantes dans le gestionnaire OnPaint du PaintBox. Cependant, je reçois toujours des objets laids. Avez-vous des conseils comment je peux me débarrasser d'eux?

Projet de test: Il suffit de créer une nouvelle application VCL et remplacer le code Unit1.pas avec ce qui suit. Ensuite, démarrez l'application et la liste de faire glisser des éléments sur le rectangle dans le 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.

Modifier Voici une image du pépin: artefact dragImage http://img269.imageshack.us/img269/6535/15778780.png

Je me attends à voir le rectangle bleu avec bordure épaisse. Cependant, sous l'image, on peut voir glisser le rectangle non mis en surbrillance.

Edit 2: Ce site parle de "questions de peinture":

  

Le SDK ImageList note que lorsque   dessin l'image de glisser, vous pouvez obtenir   problèmes avec les mises à jour ou peinture à l'écran   sauf si vous utilisez le ImageList_DragLeave   fonction API pour cacher l'image de glisser   tandis que la peinture se produit (qui est   ce que la méthode HideDragImage dans la   classe ne). Malheureusement, si vous   ne possèdent pas le contrôle qui est en cours   peint ce fait est pas vraiment une   option.

Je n'ai pas le problème mentionné dans la dernière phrase. Cependant je ne suis pas en mesure de trouver le bon endroit et le droit imagelist (il est pas ImageList1 dans mon projet de test - probablement ListView1.GetDragImages). Appeler ImageList_DragLeave

Answer 1

La clé est de cacher l'image de glisser avant que la boîte de peinture est redessinée, et de le montrer à nouveau après. Si vous remplacez ce code dans votre question:

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;

avec cette

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;

il devrait fonctionner. Eh bien, il le fait pour moi avec Delphi 2007 sur Windows XP 64 bits.

Et kudos pour le code de démonstration dans votre question, une excellente façon de nous laisser voir le problème.

Answer 2

Testé sur XP, Delphi 2010 - je reçois les objets, il est donc XP liée et non fixée dans D2010

Edit:

Après enquête - si vous faites glisser une icône pour que la souris ne pénètre que la boîte (mais l'icône ne fonctionne pas) alors que la boîte est dessiné correctement, il est seulement quand l'icône pénètre dans la boîte de couleurs que les artefacts se produisent.

J'ai ajouté le code de sorte que si l'état était dsDragMove il serait alors forcer une repeindre et cela a fonctionné, mais a souffert de scintillement