Картина TPaintBox во время перетаскивания с DragImage

Question

В моем приложении (Delphi 2007) Я хочу перетащить элементы из ListView в PaintBox и выделить соответствующие области в обработчике OnPaint PaintBox. Однако я всегда получаю уродливые артефакты. У вас есть советы, как я могу избавиться от них?

Испытательный проект: Просто создайте новое приложение VCL и замените код в Unit1.pas следующим. Затем запустите приложение и перетащите элементы списка по прямоугольнику в 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. 

Edit: Вот картина глюк: DragImage artefact http://img269.imageshack.us/img269/6535/15778780.png

Я ожидаю увидеть полный синий прямоугольник с толстой границей. Однако под изображением перетаскивания можно видеть не выделенный подсвечник.

Edit 2:This site говорит о «Роспись вопросам»:

ImageList SDK отмечает, что, когда рисования перетащить изображение, которое вы можете получить проблемы с обновления и экран картины , если вы не используете ImageList_DragLeave Функция API, чтобы скрыть изображение перетаскивания , в то время как картина ( , что делает метод HideDragImage в классе ). К сожалению, если вы не являетесь владельцем элемента управления , то это не действительно .

У меня нет проблемы, упомянутой в последнем предложении. Тем не менее, я не смог найти нужное место и правильное изображение (это не ImageList1 в моем тестовом проекте - возможно ListView1.GetDragImages) для вызова ImageList_DragLeave.

Answer 1

Ключа, чтобы скрыть перетащить изображение до коробки краски перерисовывается, и показать его снова после этого. Если вы замените этот код на свой вопрос:

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; 

с этим

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; 

он должен работать. Ну, это для меня с Delphi 2007 на Windows XP 64 бит.

И прелесть для демонстрационного кода в вашем вопросе, отличный способ позволить нам увидеть проблему.

Answer 2

Проверено на XP, Delphi 2010 - Я получаю артефакты, так что связанные с XP и не фиксируется в D2010

Edit:

После дальнейшего исследования - если вы перетащите значок так, что мышь только (но значок не отображается), тогда поле рисуется правильно, только когда значок входит в Paintbox, где происходят артефакты.

Я добавил код так, что если государство dsDragMove то вынудит перерисовку, и это сработало, но страдал от мерцаний