Я реализую функции drag-and-drop для TTreeView
. В событии OnStartDrag
я создаю DragOcject
моего производного класса:
TTreeDragControlObject = class(TDragObject)
private
FDragImages: TDragImageList;
FText: String;
protected
function GetDragImages: TDragImageList; override;
end;
procedure TfrmMain.tvTreeStartDrag(Sender: TObject;
var DragObject: TDragObject);
begin
DragObject := TTreeDragControlObject.Create;
TTreeDragControlObject(DragObject).FText := tvTree.Selected.Text;
end;
И это моя переопределяющая функция GetDragImages
моего DragObcject
:
function TTreeDragControlObject.GetDragImages: TDragImageList;
var
Bmp: TBitmap;
begin
if FDragImages = nil then
begin
FDragImages := TDragImageList.Create(nil);
Bmp := TBitmap.Create;
try
Bmp.Width := Bmp.Canvas.TextWidth(FText) + 25;
Bmp.Height := Bmp.Canvas.TextHeight(FText);
Bmp.Canvas.TextOut(25, 0, FText);
FDragImages.Width := Bmp.Width;
FDragImages.Height := Bmp.Height;
FDragImages.SetDragImage(FDragImages.Add(Bmp, nil), 0, 0);
finally
Bmp.Free;
end;
end;
Result := FDragImages;
end;
Все работает отлично, за исключением того, что при перетаскивании узлов дерева происходит сбой графики:
Как я могу избежать такого поведения?