|
セルのテキストをドラッグイメ−ジにしてグリッド(TStringGrid)でドラッグ＆ドロップを行う
|
やり方は２つあって、Drag Object をすりかえる方法と
コントロール側で DoStartDrag, DoEndDrag, GetDragImages 等を
override する方法があります。[d40216]中村
以下は、[d40948]で須賀さんが書いたコードを若干省略したものです。
Drag&Dropのやり方として大変参考になりますね。
type
TForm1 = class(TForm)
//＜省略＞
・・・・・
public
CursorSave:TCursor;
end;
type
TCustomDragObject = class(TDragControlObject)
public
function GetDragImages: TDragImageList; override;
procedure HideDragImage; override;
procedure ShowDragImage; override;
function GetDragCursor(Accepted: Boolean; X, Y: Integer)
: TCursor; override;
procedure Finished(Target: TObject; X, Y: Integer;
Accepted: Boolean); override;
end;
//＜省略＞
・・・・・
var // ローカルに宣言
w_x,w_y:integer; // もとのcellの位置を取っておく
Images: TImageList; // Image作成用
drag_sizex,drag_sizey:integer; // 作成したimageのサイズ
drag_enter_sw:smallint; // drag start時かどうかのsw
function TCustomDragObject.GetDragImages: TDragImageList;
begin
Result := Images;
end;
procedure TCustomDragObject.HideDragImage;
begin
GetDragImages.HideDragImage;
end;
procedure TCustomDragObject.ShowDragImage;
begin
GetDragImages.ShowDragImage;
end;
procedure TCustomDragObject.Finished;
begin
inherited;
Free;
end;
function TCustomDragObject.GetDragCursor;
begin
Result := crDeFault;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
drag_enter_sw := 0; // drag start時かどうかのSwをクリア
Grid1.ControlStyle := ControlStyle + [csDisplayDragImage];
// 適当にセルに文字列を・・・
Grid1.cells[1,1]:='AAA';
end;
procedure TForm1.Grid1DragOver(Sender, Source: TObject; X, Y: Integer; State: TDragState; var Accept: Boolean);
var
acol,arow:integer;
begin
if source is TCustomDragObject then
begin
Accept := True;
Grid1.mousetocell(x, y, acol, arow);
if (acol<0) or (arow<0) then //
begin
Grid1.DragCursor := crNoDrop;
exit;
end
else begin
Grid1.DragCursor := crDrag;
end;
if State=dsDragMove then
begin
if drag_enter_sw = 0 then // start drag時以外のとき
begin
if (y-drag_sizey) <= Grid1.rowheights[1] then // 上にscroll
begin
if Grid1.toprow > 1 then
begin
Grid1.toprow := Grid1.toprow - 1 ;
Grid1.repaint;
end;
end;
if (y >= (Grid1.height - 5)) then // 下にscroll
begin
if (Grid1.rowcount - Grid1.visiblerowcount)>Grid1.toprow then
begin
Grid1.toprow := Grid1.toprow + 1;
Grid1.repaint;
end;
end;
end
else
drag_enter_sw := 0;
end;
end;
end;
procedure TForm1.Grid1StartDrag(Sender: TObject;
var DragObject: TDragObject);
var Size: TSize;
bm: TBitmap;
acol,arow:integer;
begin
drag_enter_sw := 1;
// drag start時にswをたてる
Grid1.mousetocell(Grid1.screentoclient(mouse.CursorPos).x,Grid1.screentoclient(mouse.CursorPos).y, acol, arow);
w_x := acol; // drag開始時のcellの位置を取っておく
w_y := arow; // drag開始時のcellの位置を取っておく
// textのimageを作成
bm := TBitmap.Create;
bm.Canvas.Font := Font;
Size := bm.Canvas.TextExtent(Grid1.cells[acol, arow]);
bm.Width := Size.cx;
bm.Height := Size.cy;
drag_sizex := Size.cx;
drag_sizey := Size.cy;
bm.Canvas.TextOut(0, 0, Grid1.cells[acol, arow]);
Images := TImageList.Create(Self);
Images.Width := Size.cx;
Images.Height := Size.cy;
Images.Add(bm, Nil);
bm.Free;
Images.SetDragImage(0, Size.cx, Size.cy);
Images.EndDrag;
// カーソル処理
CursorSave := Screen.Cursor;
Screen.Cursor := crDefault;
// DragImageを作成
DragObject := TCustomDragObject.Create(Grid1); // dragobjectの差し替え
end;
procedure TForm1.Grid1EndDrag(Sender, Target: TObject; X, Y: Integer);
begin
Screen.Cursor := CursorSave;
Grid1.repaint;
images.free; // drag終了時にTImageListの開放 これを忘れていました !!
end;
procedure TForm1.Grid1DragDrop(Sender, Source: TObject; X, Y: Integer);
var
acol,arow:integer;
begin
Grid1.mousetocell(x, y, acol, arow);
if (acol < 0) or (arow < 0) then // scroll barや最後の行より下のところにdropしたときは何もしない
begin
Grid1.DragCursor := crNoDrop;
exit;
end;
if (Sender = Grid1) then // drag開始時のcellの内容をdropしたcellにcopy
begin
Grid1.mousetocell(x, y, acol, arow);
Grid1.cells[acol, arow] := Grid1.cells[w_x, w_y];
Grid1.repaint;
end;
end;
なお、落とし穴があります。
ＩＤＥの中では、ドラッグカーソルとドラッグイメージの合成処理の過程で(TCustomImageList.CombineDragCursor）
Win95/98 が落ちることが前は良く起きました。Video Driver の問題らしいのですが、いまだに原因が良く判らないそうです。
EXEレベルではこの障害はでません。
|
|
