Pittura TPaintBox durante Drag & Drop con DragImage
-
19-09-2019 - |
Domanda
Nella mia applicazione (Delphi 2007) Voglio trascinare elementi da un ListView a un PaintBox ed evidenziare le aree corrispondenti nel gestore OnPaint del PaintBox. Tuttavia ho sempre brutti artefatti. Avete qualche consiglio come posso liberarmi di loro?
progetto di prova: Basta creare una nuova applicazione VCL e sostituire il codice in Unit1.pas con il seguente. Quindi avviare le voci di elenco di app e trascinare il rettangolo nella 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.
Modifica Ecco una foto del problema tecnico: DragImage manufatto http://img269.imageshack.us/img269/6535/15778780.png
Mi aspetto di vedere il rettangolo blu completo di bordo spesso. Tuttavia l'immagine di trascinamento sotto si può vedere il rettangolo evidenziata.
Modifica 2: Questo sito parla di "Problemi pittura":
L'ImageList SDK osserva che quando disegnare l'immagine di trascinamento è possibile ottenere problemi con aggiornamenti o la pittura schermo a meno che non si utilizza l'ImageList_DragLeave funzione API per nascondere l'immagine di trascinamento mentre si verifica la pittura (che è ciò che il metodo HideDragImage nel Classe fa). Purtroppo, se si non proprio il controllo che viene dipinto facendo questo non è davvero un opzione.
Non ho il problema di cui l'ultima frase. Tuttavia non ero in grado di trovare il posto giusto e l'imagelist destra (è non ImageList1 nel mio progetto di test - probabilmente ListView1.GetDragImages). Per chiamare ImageList_DragLeave
Soluzione
La chiave è quello di nascondere l'immagine di trascinamento prima che la scatola di colori viene ridisegnata, e di mostrare di nuovo dopo. Se si sostituisce il codice nella tua domanda:
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 questo
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;
dovrebbe funzionare. Beh, lo fa per me con Delphi 2007 in Windows XP 64 bit.
E complimenti per il codice dimostrativo nella sua interrogazione, ottimo modo per farci vedere il problema.
Altri suggerimenti
Testato su XP, Delphi 2010 - ricevo i manufatti, quindi è correlato XP e non fissato in D2010
Modifica:
Con ulteriori indagini - se si trascina un'icona in modo che il mouse appena entra nel box (ma l'icona non lo fa), allora la casella viene disegnata correttamente, è solo quando l'icona entra nella paintbox che si verificano i manufatti.
Ho aggiunto il codice in modo che, se fosse stato dsDragMove allora sarebbe forzare una ridipingere e questo ha funzionato, ma sofferto di sfarfallio