[ 100_OnDragOver イベントを使用したコントロールのドラッグ ]

Delphi Programming / Object Pascal

[掲載 2005年01月01日] [更新 2014年02月11日]　Delphi サンプルプログラム集

100_OnDragOver イベントを使用したコントロールのドラッグ
動作確認等	Windows 7 U64(SP1) + Delphi XE Pro Windows 7 U64(SP1) + Delphi XE5(UP2) Pro FireMonkey HD

100_ControlDrag1.zip　[2,962 KB]　2014年02月11日版 (EXE 同梱)

コントロールの OnDragOver イベントを使用したドラッグ
01_コントロールごと移動
02_ドラッグ中に半透明イメージを表示
03_FireMonkey におけるコントロールのドラッグ

2012年04月11日
Delphi XE Pro で動作確認
ドラッグ中に半透明イメージを表示するサンプルを追加

2014年02月11日
FireMonkey のサンプルを追加

コントロールの OnDragOver イベントを使用したドラッグ

ビジュアルなコントロールをマウスでドラッグ・アンド・ドロップするサンプルです．
動作の名前の通り，Drag という名前のイベントを使用する例となっています．ドロップ先は同じフォームあるいは，同じ親コントロール内のパネル等です．

01_コントロールごと移動

TControl から派生したコンポーネントを，実行中にマウスでドラッグして移動します．ドラッグ中のマウスカーソルは，各コントロールの DragCursor プロパティで設定しています．

	図1 設計時画面後のテスト用に TScrollBox を配置 TPanel と TImage を配置 TImage には適当な Picture を読込んでおく
	図2 実行して TImage をドラッグ中

リスト1
OnDragOver イベントを使用したコントロールのドラッグ移動

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
  Dialogs, ExtCtrls, StdCtrls;

type
  TForm1 = class(TForm)
    ScrollBox1: TScrollBox;
    Image1: TImage;
    Panel1: TPanel;
    procedure Image1MouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure Image1DragOver(Sender, Source: TObject; X, Y: Integer;
      State: TDragState; var Accept: Boolean);
    procedure Image1DragDrop(Sender, Source: TObject; X, Y: Integer);
    procedure FormCreate(Sender: TObject);
  private
    { Private 宣言 }
  public
    { Public 宣言 }
    //ドラッグ開始位置のマウス座標
    ControlStartTop  : Integer;
    ControlStartLeft : Integer;
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

//=============================================================================
//  チラツキ防止
//=============================================================================
procedure TForm1.FormCreate(Sender: TObject);
begin
  ScrollBox1.DoubleBuffered := True;
  //縦方向だけスクロール可能にしてみる
  ScrollBox1.VertScrollBar.Visible  := True;
  //スクロールバーのドラッグと同時にスクロールさせる
  ScrollBox1.VertScrollBar.Tracking := True;
end;

//=============================================================================
//  Image1のOnMouseDownイベント
//  他のコントールのOnMouseDownイベントと共有
//
//  マウスをDownしたらドラッグ開始
//
//  DragMode = dmAutomatik
//    の時は，このマウスイベントは発生しない．自動でドラックを開始できる
//    ドラッグのカーソルはデフォルトで変更できない
//
//  DragMode = dmManual
//    にすれば発生するが，そのままではOnDragOverイベントが発生しない
//    そこで，TControl(Sender).BeginDrag(True)を実行する
//    ドラッグのカーソルは，DragCursorで指定した形状となる
//    つまり，いろいろ変更できる
//=============================================================================
procedure TForm1.Image1MouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  if Button = mbLeft then begin
    ControlStartLeft := X;
    ControlStartTop  := Y;
    TControl(Sender).BeginDrag(True);
  end;
end;

//=============================================================================
//  Image1のOnDragOverイベント
//  他のコントールのOnDragOverイベントと共有
//
//  ドラッグ中の処理
//=============================================================================
procedure TForm1.Image1DragOver(Sender, Source: TObject; X, Y: Integer;
  State: TDragState; var Accept: Boolean);
begin
  Accept := (Sender = Source);
  if Accept then begin
    TControl(Sender).Left := TControl(Sender).Left + X - ControlStartLeft;
    TControl(Sender).Top  := TControl(Sender).Top  + Y - ControlStartTop;
  end;
end;

//=============================================================================
//  Image1のOnDragDropイベント
//  他のコントールのOnDragDropイベントと共有
//
//  ドラッグ終了
//=============================================================================
procedure TForm1.Image1DragDrop(Sender, Source: TObject; X, Y: Integer);
begin
  if (Sender = Source) then begin
    TControl(Sender).Left := TControl(Sender).Left + X - ControlStartLeft;
    TControl(Sender).Top  := TControl(Sender).Top  + Y - ControlStartTop;
    EndDrag(True);
  end;
end;

end.

02_ドラッグ中に半透明イメージを表示

コントロールのドラッグ中に，半透明画像を表示するサンプルです．
この機能を実装するには，TDragControlObjectEx のオブジェクトの継承クラスのインスタンスを生成して使用します．また，ドロップ先のコントロールの ControlStyle に csDisplayDragImage が必要です．そこで，このサンプルでは以下の手順で実装してます．

(1) フォームの OnCreate で全てのコントロールに対して csDisplayDragImage を追加
(2) TDragControlObjectEx を継承したクラスを作成し，その GetDragImages メソッド内で，ドラッグ中のコントロールの画像を取得する
(3) その画像を GetDragImages メソッドの戻り値である TDragImageList に代入する
(4) OnStartDrag イベント内で，TDragControlObjectEx のインスタンスを生成する
(5) OnStartDrag イベントの DragObject 引数に TDragControlObjectEx のインスタンスを渡す
(6) TDragControlObjectEx オブジェクトが自動で，ドラッグ中に画像を半透明表示してくれる

このサンプルのコードは，旧 Nifty の FDELPHI フォーラムの「１６番会議室「玉石混淆みんなで作るSample蔵」に，ユニコムTM さんが掲載した「DragDropに連動するイメージ」の記事を参考にして作成しました．

	図3 設計時画面 TPanel, TImage, TLabel を配置 TImage には適当な Picture を読込んでおく
	図4 実行して TImage をドラッグ中コントロールが半透明画像となっているドラッグ中のカーソルは，DragCursor の設定による

リスト2
OnDragOver イベントを使用したコントロールのドラッグ移動
ドラッグ中に，コントロールを半透明画像として表示する例

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, ComCtrls, ExtCtrls;

type
  TControlDragObject = class(TDragControlObjectEx)
  private
    FDragImages: TDragImageList;
    FX : Integer;
    FY : Integer;
  protected
    function GetDragImages: TDragImageList; override;
  public
    constructor CreateStartPos(Control: TControl; X, Y: Integer);
    destructor Destroy; override;
  end;

  TForm1 = class(TForm)
    Image1: TImage;
    Panel1: TPanel;
    Label1: TLabel;
    procedure FormCreate(Sender: TObject);
    procedure Image1MouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure Image1StartDrag(Sender: TObject; var DragObject: TDragObject);
    procedure Image1EndDrag(Sender, Target: TObject; X, Y: Integer);
    procedure Image1DragOver(Sender, Source: TObject; X, Y: Integer;
      State: TDragState; var Accept: Boolean);
  private
    { Private 宣言 }
    ControlStartTop  : Integer;
    ControlStartLeft : Integer;
    FDragObject : TControlDragObject;
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

uses TypInfo;

{$R *.dfm}

{ TControlDragObjectEx }

type
  TMyGraphicControl = class(TGraphicControl);

//-----------------------------------------------------------------------------
//  TDragControlObjectExの生成と，ドラッグ開始位置の設定
//  このメソッドの名前は任意
//-----------------------------------------------------------------------------
constructor TControlDragObject.CreateStartPos(Control: TControl; X,
  Y: Integer);
begin
  inherited Create(Control);

  FX := X;
  FY := Y;
end;

//-----------------------------------------------------------------------------
//  TDragControlObjectExのDestroy処理
//-----------------------------------------------------------------------------
destructor TControlDragObject.Destroy;
begin
  FDragImages.Free;

  inherited;
end;

//-----------------------------------------------------------------------------
//  TDragControlObjectExのGetDragImagesメソッド
//
//  ここで，対象コントロールのビットマップ作成して登録する
//  ここではコントロールの画像をビットマップとしている
//  ビットマップを半透明処理するのはTDragControlObjectExが内部で行う
//-----------------------------------------------------------------------------
function TControlDragObject.GetDragImages: TDragImageList;
var
  ABmp       : TBitmap;
  ImgIndex   : Integer;
  RectImg    : TRect;
  PropInfo   : PPropInfo;
  Background : Variant;
  ACanvas    : TCanvas;
begin
  if not Assigned(FDragImages) then FDragImages := TDragImageList.Create(nil);
  Result := FDragImages;
  Result.Clear;

  ABmp := TBitmap.Create;
  try
    ABmp.PixelFormat := pf32bit;
    ABmp.Width       := Control.Width;
    ABmp.Height      := Control.Height;

    ABmp.Canvas.Lock;
    try
      if Control is TWinControl then begin
        PropInfo := GetPropInfo((Control as TWinControl), 'ParentBackground');
        if PropInfo <> nil then begin
          Background := GetPropValue((Control as TWinControl), PropInfo);
          SetPropValue((Control as TWinControl), PropInfo, False);
        end;
        (Control as TWinControl).PaintTo(ABmp.Canvas.Handle, 0, 0);
        if PropInfo <> nil then begin
          SetPropValue((Control as TWinControl), PropInfo, Background);
        end;
      end else begin
        SetRect(RectImg, 0, 0, ABmp.Width, ABmp.Height);
        if Control is TImage then begin
          ABmp.Canvas.Brush.Color := clBtnFace;
          ABmp.Canvas.FillRect(RectImg);
          ABmp.Canvas.StretchDraw(RectImg, TImage(Control).Picture.Graphic);
        end else begin
          ACanvas := TMyGraphicControl(Control).Canvas;
          //BitBltでもよい
          ABmp.Canvas.CopyRect(RectImg, ACanvas, RectImg);
        end;
      end;
    finally
      ABmp.Canvas.UnLock
    end;

    //作成したビットマップのサイズを決定し，DragImagesに追加
    if not ABmp.Empty then begin
      FDragImages.Width  := Control.Width;
      FDragImages.Height := Control.Height;

      ImgIndex := FDragImages.Add(ABmp, nil);
      FDragImages.SetDragImage(ImgIndex, FX, FY);
    end;
  finally
    ABmp.Free;
  end;
end;

//=============================================================================
//  フォーム作成時の処理
//=============================================================================
procedure TForm1.FormCreate(Sender: TObject);

  //---------------------------------------------------------------------------
  //  引数のコントロールのControlStyleにcsDisplayDragImageを追加
  //  Parentに各コントロールが配置されているフォームを指定すれば，そのフォーム
  //  上の全てのControlStyleのスタイルを変更することになる
  //---------------------------------------------------------------------------
  procedure FixControlStyles(Parent: TControl);
  var
    i : Integer;
  begin
    Parent.ControlStyle := Parent.ControlStyle + [csDisplayDragImage];
    if Parent is TWinControl then begin
      with TWinControl(Parent) do begin
        for i := 0 to ControlCount - 1 do begin
          FixControlStyles(Controls[i]);
        end;
      end;
    end;
  end;
  //---------------------------------------------------------------------------

begin
  FixControlStyles(Self);
end;

//=============================================================================
//  Image1のOnMouseDownイベント
//  他のコントールのOnMouseDownイベントと共有
//
//  マウスをDownしたらドラッグ開始
//
//  DragMode = dmAutomatik
//    の時は，このマウスイベントは発生しない．自動でドラックを開始できる
//    ドラッグのカーソルはデフォルトで変更できない
//
//  DragMode = dmManual
//    にすれば発生するが，そのままではOnDragOverイベントが発生しない
//    そこで，TControl(Sender).BeginDrag(True)を実行する
//    ドラッグのカーソルは，DragCursorで指定した形状となる
//    つまり，いろいろ変更できる
//=============================================================================
procedure TForm1.Image1MouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  if Button = mbLeft then begin
    TControl(Sender).BeginDrag(True);
  end;
end;

//=============================================================================
//  Image1のOnStartDragイベント
//  他のコントールのOnStartDragイベントと共有
//
//  ドラッグ開始時の処理
//=============================================================================
procedure TForm1.Image1StartDrag(Sender: TObject; var DragObject: TDragObject);
var
  Pt : TPoint;
begin
  GetCursorPos(Pt);

  ControlStartLeft := Pt.X;
  ControlStartTop  := Pt.Y;

  //TDragControlObjectExオブジェクトを生成
  Pt := TControl(Sender).ScreenToClient(Pt);
  FDragObject := TControlDragObject.CreateStartPos(TControl(Sender), Pt.X, Pt.Y);
  //引数のDragObjectにに渡す
  DragObject := FDragObject
end;

//=============================================================================
//  Image1のOnDragOverイベント
//  他のコントールのOnDragOverイベントと共有
//
//  ドラッグ中の処理
//  このサンプルコードの場合，SourceはTControlDragObjectExとなっている
//=============================================================================
procedure TForm1.Image1DragOver(Sender, Source: TObject; X, Y: Integer;
  State: TDragState; var Accept: Boolean);
begin
  Accept := True;
end;

//=============================================================================
//  Image1のOnDragDropイベント
//  他のコントールのOnDragDropイベントと共有
//  ドロップした位置にコントロールを描画
//
//  ドラッグ終了
//  TDragControlObjectExの場合，このオブジェクトのインスタンスの破棄は不要
//=============================================================================
procedure TForm1.Image1EndDrag(Sender, Target: TObject; X, Y: Integer);
var
  Pt : TPoint;
begin
  if Target = nil then exit;

  //イベントの引数のX,Yを使用する時は，スクリーン座標値に変換する
  GetCursorPos(Pt);

  TControl(Sender).Left := TControl(Sender).Left + (Pt.X - ControlStartLeft);
  TControl(Sender).Top  := TControl(Sender).Top  + (Pt.Y - ControlStartTop);

  Repaint;
end;

end.

下のコードは，コントロールの画像をビットマップとして取得するコードの部分です．

TWinControl の場合は，PaintTo メソッドでビットマップが取得できますが，ParentBackGround プロパティが True だと，そのコントロールの背景も含んだ画像となってしまいます．そこで，実行時型情報の取得で，ParentBackground プロパティが存在するコントロールは，その値を False にし，ビットマップ取得後に元の値に戻しています．

TGraphicControl の TImage は Picture プロパティを使用して，StretchDraw でビットマップに描画します．Windows XP の Metafile では，ビットマップの Canvas を塗り潰してから描画しないと透過部分が背景の画像となってしまうため，その対策をしています．

TImage 以外の TGraphicControl は，基本的にこのコードではコントロール全体の画像は取得できません．したがつて，ドラッグ中の画像は，フォームに表示されているままの画像となります．
もし，取得するのであれば，対象のコントロールの Paint メソッドを実行して，そのメソッド内でビットマップなりを取得することになります．

リスト3
コントロールの画像をビットマップとして取り出す部分のコード

    ABmp.Canvas.Lock;
    try
      if Control is TWinControl then begin
        PropInfo := GetPropInfo((Control as TWinControl), 'ParentBackground');
        if PropInfo <> nil then begin
          Background := GetPropValue((Control as TWinControl), PropInfo);
          SetPropValue((Control as TWinControl), PropInfo, False);
        end;
        (Control as TWinControl).PaintTo(ABmp.Canvas.Handle, 0, 0);
        if PropInfo <> nil then begin
          SetPropValue((Control as TWinControl), PropInfo, Background);
        end;
      end else begin
        SetRect(RectImg, 0, 0, ABmp.Width, ABmp.Height);
        if Control is TImage then begin
          ABmp.Canvas.Brush.Color := clBtnFace;
          ABmp.Canvas.FillRect(RectImg);
          ABmp.Canvas.StretchDraw(RectImg, TImage(Control).Picture.Graphic);
        end else begin
          ACanvas := TMyGraphicControl(Control).Canvas;
          //BitBltでもよい
          ABmp.Canvas.CopyRect(RectImg, ACanvas, RectImg);
        end;
      end;
    finally
      ABmp.Canvas.UnLock
    end;

上のコード中の Control は TDragControlObjectEx のプロパティで，ドラッグ中のコントロールを意味しています．また，TMyGraphicControl は，implementation 部の先頭部分で次のように定義しています．これは，TGraphicControl の protected 部にアクセスするための型定義です．

type
  TMyGraphicControl = class(TGraphicControl);

図5
TLabel をドラッグ中

TImage 以外の TGraphicControl ではフォームの描画状態がドラッグ中のイメージとなってしまう

03_FireMonkey におけるコントロールのドラッグ

参考用に，FireMonkey でのコントロールのドラッグのサンプルです．
FireMonkey では，全てのコントロールを Shapes タブの TSelection コントロールと組み合わせることでドラッグできるようになります．また，全てのコントロールを他のコントロールの親 (Parent) とすることができます．このことを利用します．もちろん，上のサンプルのように，イベント処理でドラッグすることも可能です．
VCL のアプリケーションでは，親になることができるのは，TPanel 等のコンテナコンポーネントと呼ばれるコントロールだけです．

本サンプルでは，上記の設定を設計時に行うことにします．新規作成した HD アプリケーションのフォームに Shapes タブの TSelection と Standard タブの TPanel を配置します．この TPanel をドラッグします．その前に，この TPanel の色を変更してみることにします．

(1) TPanel のポップアップメニューから [カスタムスタイルの編集] を選択
(2) [構造] ペインの panel1style1:TRectangle を選択
(3) オブジェクトインスペクタの Fill.Color プロパティで色を変更
(4) [適用して閉じる] で設定を終了する

これで TPanel の色が変更されます．
Panel1 の Opacity の値，または panel1style1:TRectangle の Opacity の値を変えれば半透明にもできます．次は親子関係等を設定します．

(1) [構造] ペインで Panel をマウスドラッグして Selection1 の下に移動する
(2) Panel1 の Align の値を alClient にする
(3) Panel1 の HitTest の値を False にしてマウスイベントを透過するようにする
(4) これで，マウスイベントは親である Selection1 が受け取ることになる
(5) [構造] ペインで Selection1 を選択する
(6) オブジェクトインスペクタで Selection1 の HideSelection を Trueにする

これで準備完了です，後はコンパイルして実行するだけです．

[備考]
フォーム場合，[カスタムスタイルの編集] ダイアログを表示しなくても，オブジェクトインスペクタの Fill プロパティで背景色や背景画像の設定が可能です

	図6 コントロールを配置 TSelection [Shapes] を配置 TPanel を配置．これがドラッグの対象
	図7 TPanel の色を変更 Panel1 のポップアップメニューから [カスタムスタイルの編集] を選択 [構造] ペインの panel1style1:TRectangle を選択オブジェクトインスペクタの Fill.Color の値を変更左上は自動的に追加された StyleBool1 でスタイル編集用のコンポーネント [注意] この構造ペインが表示されている時はフォームではなく，StyleBook1 の編集ウィンドウが表示される
	図8 親子関係を設定 [構造] ペインで，Panel1 を Selection1 の下に移動するこれで Panel1 の Parent (親) が Selection1 となる Panel1 の Align の値を alClient にする Panel1 の HitTest の値を False にする Selection1 の HideSelection を Trueにする

コンパイルして実行します．下図はドラッグ中の画像です．マウスカーソルはデフォルトのままですが，必要であればマウスイベントあるいはプロパティで変更することになります．
前のサンプルのように，ドラッグ中に半透明のイメージを表示したければ，ドラッグ開始と同時に，ドラッグ対象と同じコントロールを生成し，それか，あるいは，元のコントロールを半透明にしてドラッグすることで実現できるでしょう．

図9
ドラッグ中

マウスの左ボタンを押したままでコントロールを移動可

リスト4
FireMonkey におけるコントロールのドラッグ
設計時に設定しているので，追加コードは何もない

unit Unit1;

interface

uses
  System.SysUtils, System.Types, System.UITypes, System.Classes, System.Variants,
  FMX.Types, FMX.Graphics, FMX.Controls, FMX.Forms, FMX.Dialogs, FMX.StdCtrls,
  FMX.Objects;

type
  TForm1 = class(TForm)
    Selection1: TSelection;
    Panel1: TPanel;
    StyleBook1: TStyleBook;
  private
    { private 宣言 }
  public
    { public 宣言 }
  end;

var
  Form1: TForm1;

implementation

{$R *.fmx}

end.

コントロールのドラッグとは直接関係ありませんが，FireMonkey のコントロールは，プロパティの設定だけで回転ができます．RotationAngle プロパティで設定します．
下図は，この値を 30 にした時の結果です．回転の中心座標は RotationCenter で設定します．

図10
コントロールの回転