Drag блин and Drop

← →
Viktor Kushnir © (2002-09-08 13:08) [0]

Пытаюсь сделать перетаскивание одного или нескольки item"oв из ListView. Все перетаскивается и ловится все ок.
НО!

Все ок когда перетаскиваю >=2х item"ов, а вот когда только один, то курсор ДИКО тормозит. Наблидается только на TListView. На TListBox - никаких проблем.

при этом когда я тащу несколько элементов, то курсор мыши простой: стрелочка с приямоугольниками, а когода только один элемент к курсору добавляется еще и строчка Caption элемента со всем содержимым.

Как от этого избавится.

З.Ы, никакой разницы нет как управлять перетаскиванием, через своиства DragMode ли, или в ручную через BeginDrag...

← →
Viktor Kushnir © (2002-09-08 15:33) [1]

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

← →
MBo © (2002-09-09 09:54) [2]

type
TLVDragObject = class(TDragControlObject)
private
FDragImages: TDragImageList;
protected
function GetDragImages: TDragImageList; override;
function GetDragCursor(Accepted: Boolean; X, Y: Integer): TCursor; override;
public
Str: String;
destructor Destroy; override;
end;

TForm1 = class(TForm)
LV1: TListView;
Memo1: TMemo;
TreeView1: TTreeView;
procedure Memo1DragOver(Sender, Source: TObject; X, Y: Integer;
State: TDragState; var Accept: Boolean);
procedure FormCreate(Sender: TObject);
procedure LV1MouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure LV1StartDrag(Sender: TObject; var DragObject: TDragObject);
procedure Memo1DragDrop(Sender, Source: TObject; X, Y: Integer);
private
{ Private declarations }
public
{ Public declarations }
end;

var
Form1: TForm1;
ADragObject: TLVDragObject;

implementation

{$R *.DFM}

procedure TForm1.Memo1DragOver(Sender, Source: TObject; X, Y: Integer;
State: TDragState; var Accept: Boolean);
begin
Accept:=Source=ADragObject;
end;

destructor TLVDragObject.Destroy;
begin
FDragImages.Free;
inherited;
end;

function TLVDragObject.GetDragCursor(Accepted: Boolean; X,
Y: Integer): TCursor;
begin
if Accepted then Result := crNone
else Result := crNo
end;

function TLVDragObject.GetDragImages: TDragImageList;
var
B: TBitmap;
s:string;
i: Integer;
begin
if not Assigned(FDragImages) then
FDragImages := TDragImageList.Create(nil);
Result := FDragImages;
Result.Clear;
s:=ADragObject.Str;
B := TBitmap.Create;
try
B.Height :=B.Canvas.TextHeight(s);
B.Width := B.Canvas.TextWidth(s);
B.Canvas.Brush.Color := clLime;
B.Canvas.FillRect(B.Canvas.ClipRect);
B.Canvas.TextOut(0, 0,s);
Result.Width := B.Width;
Result.Height := B.Height;
i:= Result.AddMasked(B, clLime);
Result.SetDragImage(i, 0, 0);
finally
B.Free;
end
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
Memo1.ControlStyle := Memo1.ControlStyle + [csDisplayDragImage];
end;

procedure TForm1.LV1MouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
if LV1.GetItemAt(x,y)<>nil then
LV1.BeginDrag(False);
end;

procedure TForm1.LV1StartDrag(Sender: TObject;
var DragObject: TDragObject);
begin
ADragObject := TLVDragObject.Create(LV1);
if Sender=LV1 then
ADragObject.Str := LV1.Selected.Caption+" "+LV1.Selected.SubItems[0]
else
ADragObject.Str := TreeView1.Selected.Text;
DragObject := ADragObject;
end;

procedure TForm1.Memo1DragDrop(Sender, Source: TObject; X, Y: Integer);
begin
Memo1.Lines.Text:=ADragObject.Str;
end;

Спасибо!

Drag блин and Drop Найти похожие ветки