Peinture TPaintBox lors de Drag & Drop avec dragImage
-
19-09-2019 - |
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
La solution
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.
Autres conseils
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