Delphi Programming / Object Pascal
サイトのトップページへ リンクのページへ ロゴマーク
[掲載 2012年09月06日] [更新 2014年02月14日] Delphi サンプルプログラム集
   
157_移動リサイズ可能な TImage   ラバーバンドとグラブハンドル
動作確認等 Windows 7 U64(SP1) + Delphi XE Pro
Windows 7 U64(SP1) + Delphi XE5(UP2) Pro + FireMonkey HD
157_MoveResize_GrabHandle.zip [7,431 KB] 2014年02月14日版(EXE同梱)



  • 2012年09月08日
  • 最初のサンプルは,マウス左ボタン押下で選択状態にするようにした
  • 2012年09月10日
  • コンポのコード内のコメントの修正と,記事の加筆,修正
  • 2012年09月12日
  • 反転表示機能を追加
  • 移動時は Resize メソッドを実行しないようにした
  • 移動時に描画用のイベントを実行しないようにして移動時の描画速度を改善
  • 2012年09月24日
  • 動作比較のために,Delphi 7 でコンパイルした EXE を添付
  • 2012年09月28日
  • コードを少し整備
  • 2014年02月13日
  • FireMonkey のサンプルを追加




画像部分以外の部分はマウスで掴めない TImage コンポーネント


画像や図形を扱うアプリケーションの中には,画像また図形部分以外の透明部分ではマウスで掴めない,つまりマウスダウンで移動ができないものがあります.この透明部分は,マウスイベントが透過して親コントロールにメッセージが届くようになっています.

本ページのサンプルは,リージョンやパスを使わずに,この機能をテストするものです.
この機能を実現するには,画像また図形の範囲を示すラバーバンドと,グラブハンドル (GrabHandle) が必要です.そうしないと,リサイズの時にマウスで掴む場所が判断できません.GrabHandle はその名の通り,「操作部分を掴む」という意味のコントロールです.この仕様を満たすには,別のクラス(コンポーネント)を作成しないと無理があります.
そこで,実際のテストは,ラバーバンドとグラブハンドルを表示するコンポーネントを作成しました.継承元のクラスは,画像,図形を扱うのに便利な TImage としました.

本ページのコンポーネント,サンプルで,画像を扱っていますが,画像の拡大・縮小処理のサンプルではありません.TImage コントロールのリサイズのサンプルです.
一般に,画像の拡大・縮小には劣化が伴いますが,当サイトでは,画像処理関係のサンプルはほとんど扱っていません.

画像処理関係は,例えば,Torry's DELPHI に画像効果,処理関係のコンポーネントが登録されています.アルファブレンドを実装した Graphics32 には,多くのアドオンが提供されていて,機能を追加して利用できます.中村拓男さんも,DHGL というグラフィックスライブラリを提供しています.





01_プロパティ


標準の TImage に追加したプロパティです.Selected プロパティが False の時はリサイズのためのラバーバンドとグラブハンドルを表示しません.
Canvas の背景の塗り潰しの色が異なることと,Transparent が True になっていること以外は,通常の TImage コントロールと同じです.

凡例  published
 public
 ReadOnly

 Selected Boolean True にするとラバーバンドとグラブハンドルが現れ,移動リサイズが可能となる
デフォルトは False
 TransEvent Boolean マウスとキーイベント透過のフラグ
True にすると画像や図形以外の部分ではマウスで掴めなくなる
False にすると画像や図形領域内のどこでもマウスで掴める
デフォルトは False
 InverseDisp Boolean リサイズの際,座標が反転したら画像も反転表示
デフォルトは False で,反転表示しない
 BrushColor TColor この色の部分が透過色となる
画像や図形には含まれない色を指定する
デフォルトの値は RGB(190, 190, 190)
 ResizeState 列挙型 移動かリサイズ中の列挙型変数で,以下のいずれかの値
irsNone   移動でもリサイズでもない
irsMove   移動作業中
irsResize リサイズ中




02_イベント


追加したイベントは以下の 1 つだけです.このイベント内に描画コードを書きます.


OnResizeImage(Sender, ARect, ALeft, ATop, AWidth, AHeight)

引数 説明
Sender TObject コンポーネント自身
ARect TRect コンポーネントの TRect レコード型で,ClientRect と同じ値
ただし,反転表示している時は異なる値となっているので注意
ALeft Integer コンポーネントの親コントロールの左端からの X 座標値
ATop Integer コンポーネントの親コントロールの上端からの Y 座標値
AWidth Integer コンポーネントの幅
AHeight Integer コンポーネントの高さ




03_画像の移動とリサイズ   -  TCanvas に描画


TImage に画像を表示,図形を表示するには,以下の方式があります.
このコンポーネントは TImage.Stretch プロパティを False の設定で,TCanvas へ描画する方式で使用する場合に限って,画像または図形部分だけをマウスで掴めるようにしたものです.

後述のように,TPicture.Assign でも同じ仕様のコンポーネントを作成できます.どちらの方式を採用するのかは,開発するアプリケーションで,何をどのように扱うかによることになります.


TPicture.Assign あらかじめ作成した画像や図形を TImage に表示する方式
TImage.Stretch を True にすると,表示サイズを変えることができる
元の画像のサイズは変化しないので,表示サイズの変更に利用できる
TCanvas への描画に比べてリサイズ時(表示サイズ変更)の動作が軽い
TCanvasへの描画 表示する画像,図形を TCanvas に描画する方式
TImage.Stretch プロパティを False にして描画する場合,内部でオフスクリーンビットマップを使用して,画像そのもののサイズを変更する
その分 Picture.Assign に比べてリサイズ時の動作は重い



図1
設計時画面
図2
選択状態にする
  • [Button1]をクリックして画像を表示
  • 画像部分でマウスの左ボタン押下
  • ラバーバンドとグラブハンドルが表示される
  • 画像以外の部分では移動できない
図3
画像部分をマウスで掴む
  • 画像部分をマウスで掴むと移動可能
図4
反転表示
  • リサイズ中に,座標が反転した場合
図5
文字列描画とビットマップサイズ
  • フォントの設定はデフォルト
  • コントロールのサイズとビットマップのサイズは同じとなる

リスト1
画像の移動とリサイズ - TCanvas に描画
unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    Panel1: TPanel;
    Button1: TButton;
    Button2: TButton;
    CheckBox1: TCheckBox;
    procedure FormCreate(Sender: TObject);
    procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure CheckBox1Click(Sender: TObject);
  private
    { Private 宣言 }
    plImage1 : TplResizeImage;
    Bitmap   : TBitmap;
    procedure OnResizeImage(Sender: TObject; ARect: TRect; ALeft, ATop, AWidth,
      AHeight: Integer);
    procedure OnMouseDownEvent(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

//=============================================================================
//  フォーム作成時の処理
//=============================================================================
procedure TForm1.FormCreate(Sender: TObject);
begin
  Self.Caption   := '移動リサイズ可能な TImage';
  Panel1.Caption := '';
  Panel1.Color := clBtnFace;
  Panel1.DoubleBuffered := True;
end;

//=============================================================================
//  フォームを閉じる時の処理
//=============================================================================
procedure TForm1.FormCloseQuery(Sender: TObject; var CanClose: Boolean);
begin
  FreeAndNil(Bitmap);
  FreeAndNil(plImage1);
end;

//=============================================================================
//  1. ビットマップを生成
//  2. ビットマップ画像をディスクから読み出して,そのビットマップに格納
//  3. TplResizeImageを生成してイベントを定義
//  4. TplResizeImageにStretchDrawでビットマップを表示
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
var
  FileFullPath : String;
begin
  if Assigned(plImage1) then begin
    FreeAndNil(Bitmap);
    FreeAndNil(plImage1);
  end;

  FileFullPath:= '503.bmp';

  Bitmap := TBitmap.Create;
  Bitmap.LoadFromFile(FileFullPath);
  Bitmap.Transparent := True;

  //コンポーネントを生成し,イベントを定義し,位置を指定して画像を表示
  plImage1               := TplResizeImage.Create(Self);
  plImage1.Parent        := Panel1;
  plImage1.TransEvent    := True;
  plImage1.InverseDisp   := CheckBox1.Checked;
  plImage1.OnResizeImage := OnResizeImage;
  plImage1.OnMouseDown   := OnMouseDownEvent;

  plImage1.Left   := 100;
  plImage1.Top    := 50;
  plImage1.Canvas.StretchDraw(plImage1.ClientRect, Bitmap);
end;

//=============================================================================
//  TplResizeImageのOnResizeImageイベント処理
//  リサイズの度に描画コードを実行する
//=============================================================================
procedure TForm1.OnResizeImage(Sender: TObject; ARect: TRect; ALeft, ATop,
  AWidth, AHeight: Integer);
begin
  TplResizeImage(Sender).Canvas.StretchDraw(ARect, Bitmap);
end;

//=============================================================================
//  TplResizeImageのOnMouseDownイベント処理
//  左ボタン押下で選択状態にする
//=============================================================================
procedure TForm1.OnMouseDownEvent(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  if Button = mbLeft then begin
    TplResizeImage(Sender).Selected := True;
  end;
end;

//=============================================================================
//  TplResizeImageのヒットマップのサイズを確認
//=============================================================================
procedure TForm1.Button2Click(Sender: TObject);
var
  ASize : Integer;
begin
  if not Assigned(plImage1) then exit;

  plImage1.SetBounds(20, 20, 200, 200);

  plImage1.Picture.Bitmap.Canvas.TextOut(10, 10, '文字列');
  ASize := plImage1.Picture.Bitmap.Width;
  Application.MessageBox(PChar(IntToStr(ASize)), '情報');
end;

//=============================================================================
//  CheckBox1のOnClickイベント処理
//  TplResizeImageのInversDisplayプロパティの設定
//  反転表示の有効無効の設定
//=============================================================================
procedure TForm1.CheckBox1Click(Sender: TObject);
begin
  if Assigned(plImage1) then begin
    plImage1.InverseDisp := CheckBox1.Checked;
  end;
end;

end.




04_画像の移動とリサイズ  -  Picture.Assign で表示した場合


比較ために,Picture.Assign で表示した場合のテストです.
Picture.Assing で表示する場合は,イベントの設定は必要ありません.また,当然,画像部分だけをマウスで掴んでの移動はできません.画像表示領域,つまりコントロール全体,どこでもマウスで掴んでの移動が可能となります.

Picture.Assign で表示した場合は,基本的に反転表示はできません.反転表示するためには,リサイズの際に,再描画が必要です.そうすると,上のサンプルと同じとなってしまい,Picture.Assign で表示する意味が失われてしまいます.


図6
設計時画面
図7
[Button1]クリック
  • ラバーバンドとグラブハンドルが表示される
  • 画像領域内であれは,どこでもマウスダウンで移動開始できる
図8
文字列描画とビットマップサイズ
  • フォントの設定はデフォルト
  • コントロールのサイズは 200 だが,ビットマップのサイズは元のサイズのまま
  • 文字列も,元の 100 のサイズに描画されたものが拡大表示されている

上の図の結果でわかるように,Picture.Assign で表示した場合は表示サイズが変わるだけです.したがって,リサイズ表示した後に,そのサイズの画像なり図形を取得するには,例えばビットマップであれば,そのサイズのビットマップを作成し,その Canvas に描画するなり,CopyRect して,そのビットマップを,結果の画像とすることになります.
メタファイルのようなベクトル図形の場合は,元々表示サイズだけの問題だけですから,このような処理をする必然性はありません.

Picture.Assign で表示する場合も,画像,図形部分以外ではマウスで掴めないようにすることができます.上で述べたように,リサイズが終わったら(マウスの左ボタンを UP したら),TplResizeImage と同じサイズのビットマップを作成し,そこに「元のビットマップ」を,CopyRect や StretchDraw 等で描画し,そのビットマップを,TplResizeImage に再度 Picture.Assign します.
これをオフスクリーンビットマップといいます
本来の Picture.Assign と動作が違ってしまいますが,アプリの開発者が把握しておけば問題はないでしょう.必要であれば,コンポーネントを改変してください.CM_HITTEST メッセージの処理部分も修正する必要があります.


リスト2
画像の移動とリサイズ - Picture.Assign で表示した場合
unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    Panel1: TPanel;
    Button1: TButton;
    Button2: TButton;
    procedure FormCreate(Sender: TObject);
    procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
  private
    { Private 宣言 }
    plImage1 : TplResizeImage;
    Bitmap   : TBitmap;
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

//=============================================================================
//  フォーム作成時の処理
//=============================================================================
procedure TForm1.FormCreate(Sender: TObject);
begin
  Self.Caption   := '移動リサイズ可能な TImage';
  Panel1.Caption := '';
  Panel1.Color   := clBtnFace;
  Panel1.DoubleBuffered := True;
end;

//=============================================================================
//  フォームを閉じる時の処理
//=============================================================================
procedure TForm1.FormCloseQuery(Sender: TObject; var CanClose: Boolean);
begin
  FreeAndNil(Bitmap);
  FreeAndNil(plImage1);
end;

//=============================================================================
//  1. ビットマップを生成
//  2. ビットマップ画像をディスクから読み出して,そのビットマップに格納
//  3. TplResizeImageにPicture.Assignでビットマップを表示
//
//  TplImage1.Picture.Assign(Bitmap)などで表示する場合
//  TplImage1.Stretch := True; とする
//  この方式は,画像または図形の領域内(矩形領域)全てでドラッグが開始できる
//  TplReszieImageのOnResizeImageイベントの設定は不要
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
var
  FileFullPath : String;
begin
  if Assigned(plImage1) then begin
    FreeAndNil(Bitmap);
    FreeAndNil(plImage1);
  end;

  FileFullPath:= '503.bmp';

  Bitmap := TBitmap.Create;
  Bitmap.LoadFromFile(FileFullPath);
  Bitmap.Transparent := True;

  //コンポーネントを生成し,位置を指定して画像を表示
  plImage1        := TplResizeImage.Create(Self);
  plImage1.Parent := Panel1;

  plImage1.Left := 100;
  plImage1.Top  := 50;
  //Picture.Assignで表示した場合は,StretchをTrueにしないとリサイズできない
  plImage1.Stretch := True;
  plImage1.Picture.Assign(Bitmap);

  //SelectedプロパティをTrueにするとラバーバンドとグラブハンドルが表示される
  plImage1.Selected := True;
end;

//=============================================================================
//  TImageのヒットマップのサイズを確認
//  Picture.AssignでTImageに描画した場合
//
//  Picture.Assignは,元のサイズは変わらないので,[拡大表示]等に使用可能
//  ビットマップそのもののサイズを変更するには,Draw系の関数で描画する
//=============================================================================
procedure TForm1.Button2Click(Sender: TObject);
var
  ASize : Integer;
begin
  if not Assigned(plImage1) then exit;

  plImage1.SetBounds(20, 20, 200, 200);

  plImage1.Picture.Bitmap.Canvas.TextOut(10, 10, '文字列');
  ASize := plImage1.Picture.Bitmap.Width;
  Application.MessageBox(PChar(IntToStr(ASize)), '情報');
end;

end.




05_一般的な図形の例


TCanvas に Ellipse 関数で楕円を描画する例です.マウスイベントの透過動作を確認するテストもできるようにしています.

同じ「リサイズ」のサンプルですが,上の 2 つのサンプルでは,画像の中に線分があれば,リサイズするとその線の太さも変わります.一方,このサンプルは,TShape のように,サイズの違う円,楕円にする,という意味あいのものです.


図9
設計時画面
図10
[Button1]クリック
  • ラバーバンドとグラブハンドルが表示される
  • 線の部分以外では移動開始できない
  • 線の太さが細いと掴みにくい
図11
マウスイベント透過テスト
  • 図形以外の部分でマウスダウン
  • Label1 に Mouse Down と表示される

リスト3
一般的な図形の例
unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    Button1: TButton;
    Panel1: TPanel;
    Label1: TLabel;
    procedure FormCreate(Sender: TObject);
    procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);
    procedure Button1Click(Sender: TObject);
    procedure Panel1MouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure Panel1MouseUp(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
  private
    { Private 宣言 }
    plImage1 : TplResizeImage;
    procedure OnResizeImage(Sender: TObject; ARect: TRect; ALeft, ATop, AWidth,
      AHeight: Integer);
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

//=============================================================================
//  フォーム作成時の処理
//=============================================================================
procedure TForm1.FormCreate(Sender: TObject);
begin
  Self.Caption   := '移動リサイズ可能な TImage';
  Panel1.Caption := '';
  Panel1.Color   := clWhite;
  Panel1.DoubleBuffered := True;
end;

//=============================================================================
//  フォームを閉じる時の処理
//=============================================================================
procedure TForm1.FormCloseQuery(Sender: TObject; var CanClose: Boolean);
begin
  FreeAndNil(plImage1);
end;

//=============================================================================
//  1. TplResizeImageを生成してイベントを定義
//  2. 位置とサイズを指定
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
begin
  if Assigned(plImage1) then begin
    FreeAndNil(plImage1);
  end;

  //コンポーネントを生成し,イベントを定義し,位置を指定して画像を表示
  plImage1            := TplResizeImage.Create(Self);
  plImage1.Parent     := Panel1;
  plImage1.TransEvent := True;
  plImage1.OnResizeImage := OnResizeImage;

  plImage1.SetBounds(100, 50, 200, 100);

  //SelectedプロパティをTrueにするとラバーバンドとグラブハンドルが表示される
  plImage1.Selected := True;
end;

//=============================================================================
//  TplResizeImageのOnResizeImageイベント処理
//  リサイズの度に描画コードを実行する
//
//  線の太さを指定して再描画しているので,拡大しても線は太くならない
//=============================================================================
procedure TForm1.OnResizeImage(Sender: TObject; ARect: TRect; ALeft, ATop,
  AWidth, AHeight: Integer);
var
  ASize : Integer;
  AHalf : Integer;
begin
  ASize := 4;
  AHalf := ASize div 2;

  plImage1.Canvas.Pen.Width := ASize;
  plImage1.Canvas.Pen.Color := clTeal;
  plImage1.Canvas.Ellipse(AHalf, AHalf, AWidth - AHalf, AHeight - AHalf);
end;

//=============================================================================
//  Panel2のOnMouseDownイベント
//  マウスイベント透過のテスト用
//=============================================================================
procedure TForm1.Panel1MouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  Label1.Caption := 'Mouse Down';
end;

//=============================================================================
//  Panel2のOnMouseUpイベント
//  マウスイベント透過のテスト用
//=============================================================================
procedure TForm1.Panel1MouseUp(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  Label1.Caption := 'Mouse Up';
end;

end.




06_コンポーネントのソースコード


テストに使用したコンポーネントのソースコードです.以下の様な仕様となっています.
  • 画像や図形部分以外では「マウスで掴む」ことができないようにすることが可能
    この時,マウスとキーイベントは親コントロールに送られる
  • 複数のコントロールを選択して操作する状況は考慮していない
  • ラバーバンドの形状は固定で,回転はサポートしていない
  • グラブハンドルの形状も固定
このコンポーネントは TImage の派生コントロールですが,他のコンポーネントから派生すれば,いろいろなコントロールにも対応可能です.TPaintBox,TLabel,TGraphicControl 等を派生元にした場合は,TShape コンポーネントのように,描画コードは Paint メソッドあるいるは OnPaint イベントあるいは,TCanvas や 座標値等を引数に持つイベントを実装して処理することになります.

複数の図形を扱うアプリケーションでは,図形あるいは,類似の図形専用のクラスを作成するなどの工夫が必要です.また,複数の画像の処理を行うためのコーディングも必要となるでしょう.

処理が重たいようであれば,移動リサイズの際に画像を同時に移動リサイズしないで,ラバーバンドだけを表示し,移動後あるいはリサイズ後に表示するという仕様にすることも考えられます.
また,移動またはリサイズ中に画像や図形を半透明表示したい場合は,OnMouseMove イベントではなく OnDragOver イベントを使用するコードに変更する必要があります.

コンポーネントのコードは,以下のサンプルプログラム集等も参考にしてください.マウスとキーイベントの透過は,CM_HITTEST メッセージで処理しています.

CM_HITTEST メッセージで,全てのマウスメッセージを TImage に送ることができます.TImage で画像部分以外の部分で,親コントロールにマウスメッセージ送るには,画像部分とそれ以外を区別する「何か」が必要です.Delphi 2009 以上であれば「透明化」ができますが,Delphi 2007 以前でも使用可能にするために,このコンポーネントでは「色」で判断するようにしています.

TImage の Canvas をある色で塗り潰します.TImage の Transparent を True にすればこの色は実際には見えませんが,色の検出はできます.そこで,マウスカーソル下のピクセルの色が,この「ある色」の時には,マウスイベントを「透過」して,親コントロールで受け取るようにしています.


リスト4
移動リサイズ可能な TImage コンポーネントのソースコード
unit plResizeImage;

interface

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

type
  //forward宣言
  TplResizeImage = class;

  //移動かリサイズかの状態フラグ
  TplImageResizeState =(irsNone, irsMove, irsResize);

  TplRubberShape = class(TShape)
  protected
    procedure CMHitTest(var Message: TCMHitTest); message CM_HITTEST;
  end;

  TplGrabShape = class(TShape)
  private
    FplImage     : TplResizeImage;
    FMouseStartY : Integer;
    FMouseStartX : Integer;
  protected
    procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X: Integer;
      Y: Integer); override;
    procedure MouseMove(Shift: TShiftState; X: Integer; Y: Integer); override;
    procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X: Integer;
      Y: Integer); override;
    procedure CMMouseleave(var Message: TMessage); message CM_MOUSELEAVE;
  public
    constructor Create(AOwner: TComponent); override;
  end;

  TplResizeEvent = procedure (Sender: TObject; ARect: TRect; ALeft, ATop, AWidth,
    AHeight: Integer) of Object;

  TplResizeImage = class(TImage)
  private
    FSelected        : Boolean;
    FTransEvent      : Boolean;
    FBrushColor      : TColor;
    FRubberShape     : TplRubberShape;
    FGrabSize        : Integer;
    FGrabSizeHalf    : Integer;
    FGrabList        : TList;
    FGrabCount       : Integer;
    FResizeState     : TplImageResizeState;
    FMouseStartY     : Integer;
    FMouseStartX     : Integer;
    FInversHorz      : Boolean;
    FInversVert      : Boolean;
    FIsAfterHorzMove : Boolean;
    FIsAfterVertMove : Boolean;
    FInverseDisp     : Boolean;
    FOnResizeImage   : TplResizeEvent;
    procedure SetSelected(const Value: Boolean);
    procedure SetInverseDisp(const Value: Boolean);
  protected
    procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X: Integer;
      Y: Integer); override;
    procedure MouseMove(Shift: TShiftState; X: Integer; Y: Integer); override;
    procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X: Integer;
      Y: Integer); override;
    procedure CMMouseleave(var Message: TMessage); message CM_MOUSELEAVE;
    procedure Resize; override;
    procedure CMHitTest(var Message: TCMHitTest); message CM_HITTEST;
    procedure SetGrabHandleBounds(Sender: TControl);
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    property ResizeState : TplImageResizeState read FResizeState;
  published
    property InverseDisp   : Boolean        read FInverseDisp   write SetInverseDisp;
    property Selected      : Boolean        read FSelected      write SetSelected;
    property TransEvent    : Boolean        read FTransEvent    write FTransEvent;
    property BrushColor    : TColor         read FBrushColor    write FBrushColor;
    property OnResizeImage : TplResizeEvent read FOnResizeImage write FOnResizeImage;
  end;

procedure Register;

implementation

{ TplResizeImage }

//=============================================================================
//  TplResizeImageクラス
//  初期化
//=============================================================================
constructor TplResizeImage.Create(AOwner: TComponent);
begin
  inherited;

  FSelected   := False;
  FTransEvent := False;

  FBrushColor        := RGB(190, 190, 190);
  Transparent        := True;
  Stretch            := False;
  Canvas.Brush.Color := FBrushColor;
  Canvas.FillRect(ClientRect);

  FGrabSize     := 8;
  FGrabSizeHalf := FGrabSize div 2;
  FGrabCount    := 8;

  FResizeState := irsNone;

  FInversHorz      := False;
  FInversVert      := False;
  FIsAfterHorzMove := False;
  FIsAfterVertMove := False;
  FInverseDisp     := False;
end;

//=============================================================================
//  TplResizeImageクラス
//  終了処理
//=============================================================================
destructor TplResizeImage.Destroy;
var
  i : Integer;
begin
  if Assigned(FRubberShape) then FreeAndNil(FRubberShape);
  if Assigned(FGrabList) then begin
    for i := 0 to FGrabList.Count - 1 do begin
      TplGrabShape(FGrabList[i]).Free;
    end;
    FreeAndNil(FGrabList);
  end;

  inherited;
end;

//=============================================================================
//  TplResizeImageクラス
//  Selectedプロパティの設定用メソッド
//  ラバーバンドとグラブハンドルの生成
//=============================================================================
procedure TplResizeImage.SetSelected(const Value: Boolean);
var
  i      : Integer;
  AShape : TplGrabShape;
begin
  FSelected := Value;

  //ラバーバンド作成
  if FSelected then begin
    if not Assigned(FRubberShape) then begin
      FRubberShape             := TplRubberShape.Create(Self);
      FRubberShape.Parent      := Parent;
      FRubberShape.Brush.Style := bsClear;
      FRubberShape.Pen.Style   := psDot;

      //グラブハンドルを作成して配列に格納
      FGrabList := TList.Create;
      for i := 0 to FGrabCount -1 do begin
        AShape := TplGrabShape.Create(Self);
        AShape.Parent      := Parent;
        AShape.Width       := FGrabSize;
        AShape.Height      := FGrabSize;
        AShape.Brush.Style := bsSolid;
        AShape.DragMode    := dmManual;
        AShape.Tag         := i;
        FGrabList.Add(AShape);
      end;
    end;
    Resize;
  end else begin
    FSelected := False;
    if Assigned(FRubberShape) then FreeAndNil(FRubberShape);
    if Assigned(FGrabList) then begin
      for i := 0 to FGrabList.Count - 1 do begin
        TplGrabShape(FGrabList[i]).Free;
      end;
      FreeAndNil(FGrabList);
    end;
  end;
end;

//=============================================================================
//  TplResizeImageクラス
//  InversDisplayプロパティの設定用メソッド
//  反転表示をするかの設定
//=============================================================================
procedure TplResizeImage.SetInverseDisp(const Value: Boolean);
begin
  FInverseDisp := Value;
  if not FSelected then exit;
  if FResizeState <> irsNone then exit;

  FRubberShape.SetBounds(Left, Top, Width, Height);
  SetGrabHandleBounds(Self);

  FIsAfterHorzMove := FInversHorz;
  FIsAfterVertMove := FInversVert;
end;

//=============================================================================
//  TplResizeImageクラス
//  移動開始
//=============================================================================
procedure TplResizeImage.MouseDown(Button: TMouseButton; Shift: TShiftState; X,
  Y: Integer);
var
  ARect : TRect;
begin
  inherited;
  if not FSelected then exit;

  if Button = mbLeft then begin
    FResizeState := irsMove;

    FMouseStartX := X;
    FMouseStartY := Y;

    //マウスカーソルのクリップ
    //親コントロールのクライアント領域の外側には移動できない(移動不可)にする
    GetWindowRect(Parent.Handle, ARect);
    ClipCursor(@ARect);
  end;
end;

//=============================================================================
//  TplResizeImageクラス
//  移動中の処理
//=============================================================================
procedure TplResizeImage.MouseMove(Shift: TShiftState; X, Y: Integer);
var
  ALeft : Integer;
  ATop  : Integer;
begin
  inherited;
  if not FSelected then exit;

  if FResizeState = irsMove then begin
    //コントロールの位置を変更
    ALeft := Left + X - FMouseStartX;
    ATop  := Top  + Y - FMouseStartY;

    //SetBoundsを実行すると,Resizeメソッドが自動実行される
    SetBounds(ALeft, ATop, Width, Height);
    FRubberShape.SetBounds(ALeft, ATop, Width, Height);
    SetGrabHandleBounds(Self);

    //移動後はグラブハンドルがデフォルトの順になっている
    //反転表示している場合元に戻ってしまうのでフラグを使用
    FIsAfterHorzMove := FInversHorz;
    FIsAfterVertMove := FInversVert;
  end;
end;

//=============================================================================
//  TplResizeImageクラス
//  移動終了
//=============================================================================
procedure TplResizeImage.MouseUp(Button: TMouseButton; Shift: TShiftState; X,
  Y: Integer);
begin
  inherited;
  if not FSelected then exit;

  FResizeState := irsNone;
  //マウスクリップの解除
  ClipCursor(nil);
end;

//=============================================================================
//  TplResizeImageクラス
//  TImageのResizeメソッド
//  リサイズが発生すると自動的に呼ばれる
//=============================================================================
procedure TplResizeImage.Resize;
var
  ALeft        : Integer;
  ATop         : Integer;
  AWidth       : Integer;
  AHeight      : Integer;
  ARect        : TRect;
  GrabLeftTag0 : Integer;
  GrabLeftTag2 : Integer;
  GrabTopTag0  : Integer;
  GrabTopTag6  : Integer;
begin
  if not FSelected then begin
    inherited Resize;
    exit;
  end;
  if FResizeState = irsMove then exit;

  ALeft   := Left;
  ATop    := Top;
  AWidth  := Width;
  AHeight := Height;

  if FResizeState = irsResize then begin

    //リサイズでは幅と高さが負の値になることがあるので,その処理
    if AWidth <= 0 then begin
      AWidth := Abs(AWidth);
      if AWidth <= 1 then AWidth := 1;
      ALeft  := ALeft - AWidth;
    end;
    if AHeight <= 0 then begin
      AHeight := Abs(AHeight);
      if AHeight <= 1 then AHeight := 1;
      ATop    := ATop - AHeight;
    end;;
  end;;
  SetBounds(ALeft, ATop, AWidth, AHeight);


  //反転描画の判定コード
  if FResizeState = irsResize then begin
    if FInverseDisp then begin
      GrabLeftTag0 := TplGrabShape(FGrabList[0]).Left;
      GrabLeftTag2 := TplGrabShape(FGrabList[2]).Left;
      GrabTopTag0  := TplGrabShape(FGrabList[0]).Top;
      GrabTopTag6  := TplGrabShape(FGrabList[6]).Top;

      //横方向
      if FIsAfterHorzMove then begin
        if (GrabLeftTag0 > GrabLeftTag2) then begin
          FInversHorz := False;
        end else begin
          FInversHorz := True;
        end;
      end else begin
        if GrabLeftTag0 > GrabLeftTag2 then begin
          FInversHorz := True;
        end else begin
          FInversHorz := False;
        end;
      end;

      //縦方向
      if FIsAfterVertMove then begin
        if GrabTopTag0 > GrabTopTag6 then begin
          FInversVert := False;
        end else begin
          FInversVert := True;
        end;
      end else begin
        if GrabTopTag0 > GrabTopTag6 then begin
          FInversVert := True;
        end else begin
          FInversVert := False;
        end;
      end;
    end;
  end;


  //反転の状態に応じて描画領域のTRectレコード型の値を設定
  if FInversHorz and FInversVert then begin
    SetRect(ARect, AWidth, AHeight, 0, 0);
  end else
  if FInversHorz then begin
    SetRect(ARect, AWidth, 0, 0, AHeight);
  end else
  if FInversVert then begin
    SetRect(ARect, 0, AHeight, AWidth, 0);
  end else begin
    SetRect(ARect, 0, 0, AWidth, AHeight);
  end;

  if FResizeState <> irsMove then begin
    if Assigned(FOnResizeImage) then begin
      if not Stretch then begin
        //透過処理のために背景を塗り潰す
        Picture.Assign(nil);
        Canvas.Brush.Color := BrushColor;
        Canvas.FillRect(ClientRect);
        FOnResizeImage(Self, ARect, ALeft, ATop, AWidth, AHeight);
      end;
    end;
  end;

  //このコードは,外部からこのコンポのサイズを設定した場合に必要
  if FResizeState <> irsResize then begin
    FRubberShape.SetBounds(ALeft, ATop, AWidth, AHeight);
    SetGrabHandleBounds(Self);

    FIsAfterHorzMove := FInversHorz;
    FIsAfterVertMove := FInversVert;
  end;

  inherited Resize;
end;

//=============================================================================
//  TplResizeImageクラス
//  グラブハンドルの位置の設定
//  グラブハンドルのクラスからも呼出して使用するので,独立した関数にしている
//
//  [備考]
//  グラブの移動の比率で,グラブハンドル配列のループ処理で位置を再計算という操
//  作も可能
//=============================================================================
procedure TplResizeImage.SetGrabHandleBounds(Sender: TControl);
var
  ALeft      : Integer;
  ATop       : Integer;
  ARight     : Integer;
  ABottom    : Integer;
  WidthHalf  : Integer;
  HeightHalf : Integer;
begin
  ALeft      := Sender.Left;
  ATop       := Sender.Top;
  ARight     := Sender.Left  + Sender.Width;
  ABottom    := Sender.Top   + Sender.Height;
  WidthHalf  := (Sender.Left + ARight)  div 2;
  HeightHalf := (Sender.Top  + ABottom) div 2;

  TplGrabShape(FGrabList[0]).SetBounds(
     ALeft - FGrabSizeHalf, Sender.Top - FGrabSizeHalf, FGrabSize, FGrabSize);

  TplGrabShape(FGrabList[1]).SetBounds(
    WidthHalf - FGrabSizeHalf, ATop - FGrabSizeHalf, FGrabSize, FGrabSize);

  TplGrabShape(FGrabList[2]).SetBounds(
    ARight - FGrabSizeHalf, ATop - FGrabSizeHalf, FGrabSize, FGrabSize);

  TplGrabShape(FGrabList[3]).SetBounds(
    ARight - FGrabSizeHalf, HeightHalf - FGrabSizeHalf, FGrabSize, FGrabSize);

  TplGrabShape(FGrabList[4]).SetBounds(
    ARight - FGrabSizeHalf, ABottom - FGrabSizeHalf, FGrabSize, FGrabSize);

  TplGrabShape(FGrabList[5]).SetBounds(
    WidthHalf - FGrabSizeHalf, ABottom - FGrabSizeHalf, FGrabSize, FGrabSize);

  TplGrabShape(FGrabList[6]).SetBounds(
    ALeft - FGrabSizeHalf, ABottom - FGrabSizeHalf, FGrabSize, FGrabSize);

  TplGrabShape(FGrabList[7]).SetBounds(
    ALeft - FGrabSizeHalf, HeightHalf - FGrabSizeHalf, FGrabSize, FGrabSize);
end;

//=============================================================================
//  TplResizeImageクラス
//  画像または図形の透過部分は,マウスとキーイベントを透過させる
//=============================================================================
procedure TplResizeImage.CMHitTest(var Message: TCMHitTest);
var
  AColor : TColor;
begin
  if Stretch then begin
    if FSelected then begin
      Screen.Cursor := crSizeAll;
    end else begin
      Screen.Cursor := crDefault;
    end;
    Message.Result := 1;
  end else begin
    AColor := Canvas.Pixels[Message.XPos, Message.YPos];
    if (AColor = Canvas.Brush.Color) and (FTransEvent) then begin
      Screen.Cursor := crDefault;
      Message.Result := 0;
    end else begin
      if FSelected then begin
        Screen.Cursor := crSizeAll;
      end else begin
        Screen.Cursor := crDefault;
      end;
      Message.Result := 1;
    end;
  end;
end;

//=============================================================================
//  TplResizeImageクラス
//  CM_MOUSELEAVEメッセージ処理
//  マウスがコントロールから離れたらカーソルの形をデフォルトに戻す
//=============================================================================
procedure TplResizeImage.CMMouseleave(var Message: TMessage);
begin
  inherited ;
  if not FSelected then exit;

  Screen.Cursor := crDefault;
  FResizeState  := irsNone;
end;


{ TplRubberShape }

//=============================================================================
//  ラバーバンドクラスの実装はこれだけ
//  CM_HITTESTメッセージ処理
//  TplResizeImageがマウスイベントを捕捉できるようにイベントを透過する
//  TGraphicControlはデフォルトではキーイベントは透過する
//=============================================================================
procedure TplRubberShape.CMHitTest(var Message: TCMHitTest);
begin
  Message.Result := 0;
end;


{ TplGrabShape }

//=============================================================================
//  グラブハンドルのクラス
//  AOwnerはTplResizeImageとする
//=============================================================================
constructor TplGrabShape.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FplImage := TplResizeImage(AOwner);
end;

//=============================================================================
//  グラブハンドルのクラス
//  MouseDownでリサイズ開始
//=============================================================================
procedure TplGrabShape.MouseDown(Button: TMouseButton; Shift: TShiftState; X,
  Y: Integer);
var
  ARect : TRect;
begin
  inherited;

  if Button = mbLeft then begin
    FplImage.FResizeState := irsResize;

    FMouseStartX := X;
    FMouseStartY := Y;

    //マウスカーソルのクリップ
    //親コントロールのクライアント領域の外側には移動できない(移動不可)にする
    GetWindowRect(Parent.Handle, ARect);
    ClipCursor(@ARect);
  end;
end;

//=============================================================================
//  グラブハンドルのクラス
//  リサイズ中の処理
//=============================================================================
procedure TplGrabShape.MouseMove(Shift: TShiftState; X, Y: Integer);
var
  RubberWidth  : Integer;
  RubberHeight : Integer;
  DX           : Integer;
  DY           : Integer;
  ALeft        : Integer;
  ATop         : Integer;
  AWidth       : Integer;
  AHeight      : Integer;
begin
  inherited;

  //グラブハンドルの位置によってカーソルの形を変更する
  //グラブハンドルのTag番号は右回りで,0,1,2,...
  RubberWidth  := FplImage.FRubberShape.Width;
  RubberHeight := FplImage.FRubberShape.Height;
  if (Tag in [1, 5]) then Screen.Cursor := crSizeNS;
  if (Tag in [3, 7]) then Screen.Cursor := crSizeWE;
  if (Tag in [0, 4]) then begin
    if (RubberWidth * RubberHeight) < 0 then begin
      Screen.Cursor := crSizeNESW;
    end else begin
      Screen.Cursor := crSizeNWSE;
    end;
  end;
  if (Tag in [2, 6]) then begin
    if (RubberWidth * RubberHeight) < 0 then begin
      Screen.Cursor := crSizeNWSE;
    end else begin
      Screen.Cursor := crSizeNESW;
    end;
  end;


  if FplImage.FResizeState = irsResize then begin
    //グラブハンドル位置の変化量
    DX := X - FMouseStartX;
    DY := Y - FMouseStartY;

    //各グラブの新しい位置を計算
    //現在操作中のグラブの位置は以下で設定できるが,後で一括処理する
    //現在ドラッグ中のグラブだけを移動する場合は,このコードで十分
    //Left := Left + DX;
    //Top  := Top  + DY;

    ALeft   := FplImage.FRubberShape.Left;
    ATop    := FplImage.FRubberShape.Top;
    AWidth  := FplImage.FRubberShape.Width;
    AHeight := FplImage.FRubberShape.Height;

    if Tag = 0 then begin
      ALeft   := ALeft   + DX;
      AWidth  := AWidth  - DX;
      ATop    := ATop    + DY;
      AHeight := AHeight - DY;
    end else
    if Tag = 1 then begin
      ATop    := ATop    + DY;
      AHeight := AHeight - DY;
    end else
    if Tag = 2 then begin
      AWidth  := AWidth  + DX;
      ATop    := ATop    + DY;
      AHeight := AHeight - DY;
    end else
    if Tag = 3 then begin
      AWidth  := AWidth  + DX;
    end else
    if Tag = 4 then begin
      AWidth  := AWidth  + DX;
      AHeight := AHeight + DY;
    end else
    if Tag = 5 then begin
      AHeight := AHeight + DY;
    end else
    if Tag = 6 then begin
      ALeft   := ALeft   + DX;
      AWidth  := AWidth  - DX;
      AHeight := AHeight + DY;
    end else
    if Tag = 7 then begin
      ALeft   := ALeft   + DX;
      AWidth  := AWidth  - DX;
    end;

    //ラバーバンドの位置とサイズを幅と高さが負の値のまま設定
    FplImage.FRubberShape.SetBounds(ALeft, ATop, AWidth, AHeight);
    FplImage.SetGrabHandleBounds(FplImage.FRubberShape);
    //TImageは,負の値の時も含めて,FplImageのResizeメソッドで修正する
    FplImage.SetBounds(ALeft, ATop, AWidth, AHeight);
  end;
end;

//=============================================================================
//  グラブハンドルのクラス
//  リサイズ終了
//
//  ラバーバンドとグラブハンドルの位置とサイズの再設定
//  リサイズで幅や高さが負の値になっている場合があるので正の値に戻す
//=============================================================================
procedure TplGrabShape.MouseUp(Button: TMouseButton; Shift: TShiftState; X,
  Y: Integer);
begin
  inherited;
  FplImage.FResizeState := irsNone;

  //ラバーバンドとグラブハンドルの位置とサイズの再設定
  //リサイズで幅や高さが負の値になっている場合があるので正の値に戻す
  FplImage.FRubberShape.SetBounds(FplImage.Left,
                                  FplImage.Top,
                                  FplImage.Width,
                                  FplImage.Height);
  FplImage.SetGrabHandleBounds(FplImage.FRubberShape);

  //マウスの移動範囲をスクリーン画面サイズに戻す
  ClipCursor(nil);
end;

//=============================================================================
//  グラブハンドルのクラス
//  マウスがグラブハンドルから離れたらカーソルの形をデフォルトに戻す
//=============================================================================
procedure TplGrabShape.CMMouseleave(var Message: TMessage);
begin
  inherited;
  Screen.Cursor := crDefault;
  FplImage.FResizeState  := irsNone;
end;

//=============================================================================
//   コンポーネント登録情報
//=============================================================================
procedure Register;
begin
  RegisterComponents('plXRAY', [TplResizeImage]);
end;

end.




07_FireMonkey による画像の移動リサイズ - OnPainting


FireMonkey では,Shapes タブの TSelection コンポーネントをフォームに配置するだけで,実行時にこの TSelection コンポーネントがマウスで移動リサイズできます.
本サンプルは,TSelection コンポーネントの OnPainting イベントを使用して,このイベント内でディスクから画像ファイルを読み込んで表示します.図形などを移動リサイズするには,このイベント内で図形類を描画します.

OnPaint や OnPainting イベントで描画処理する方法は,GDI+ のサンプルで多く使用しています.この方法は,固定した画像を表示するのではなく,描画内容を頻繁に更新する必要がある場合に使用されています.

必要であれば画像のビットマップをグローバル変数にして処理します.
また,移動リサイズ中のマウスカーソルの形状はデフォルトのままにしています.必要に応じて変更することになります.




図12
設計時画面
  • TSelection のみ配置
図13
実行画面

リスト5
TSelection の OnPainting イベントによる画像の移動リサイズ
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;
    procedure Selection1Painting(Sender: TObject; Canvas: TCanvas;
      const ARect: TRectF);
  private
    { private 宣言 }
  public
    { public 宣言 }
  end;

var
  Form1: TForm1;

implementation

{$R *.fmx}

//=============================================================================
//  Selection1のOnPaintingイベント処理
//  ディスクから画像を読み出して描画
//=============================================================================
procedure TForm1.Selection1Painting(Sender: TObject; Canvas: TCanvas;
  const ARect: TRectF);
var
  srcBitmap : TBitmap;
  srcRect   : TRectF;
begin
  srcBitmap := TBitmap.CreateFromFile('503.bmp');
  try
    srcRect := RectF(0, 0, srcBitmap.Width, srcBitmap.Height);
    Canvas.DrawBitmap(srcBitmap, srcRect, ARect, 1.0, False);
  finally
    FreeAndNil(srcBitmap);
  end;
end;

end.




08_FireMonkey の OnMouseMove イベントによる移動リサイズ


上のサンプルで使用した TSelection コンポーネントを使用すると,他のコントロール類の移動リサイズも比較的簡単に実装できます.そのサンプルです.

TSelection コンポーネントの移動リサイズと同時に,他のコントロールも移動リサイズすれば,各種コントロールの移動リサイズができることになります.
本サンプルでは,マウスで選択した TImage または TPanel を移動リサイズします.どのコントロールを対象とするかは,TSelection の TagObject プロパティに代入しておきます.そして,TSelection の OnMouseMove イベントで処理します.TSelection はグラブハンドル (グリップ - Grip) を含めて 1 つのコントロールですから,OnResize イベントの処理は必要ありません.リサイズの際にマウスカーソルの移動が伴い,OnMouseMove イベントが発生します.




図14
設計時画面
  • 左から TImage, TPanel, TSelection
  • TPanel は色を変更している
図15
TImage をリサイズ中

リスト6
TSelection の OnMouseMove イベントによるコントロールの移動リサイズ
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)
    Image1: TImage;
    Selection1: TSelection;
    Panel1: TPanel;
    StyleBook1: TStyleBook;
    procedure FormShow(Sender: TObject);
    procedure Image1MouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Single);
    procedure Selection1MouseMove(Sender: TObject; Shift: TShiftState; X,
      Y: Single);
  private
    { private 宣言 }
  public
    { public 宣言 }
  end;

var
  Form1: TForm1;

implementation

{$R *.fmx}

//=============================================================================
//  フォーム表示開始時の処理
//  ビットマップ画像を読み込んでImage1に表示
//=============================================================================
procedure TForm1.FormShow(Sender: TObject);
var
  srcBitmap : TBitmap;
  srcRect   : TRectF;
  dstRect   : TRectF;
begin
  Selection1.Visible := False;

  srcBitmap := TBitmap.CreateFromFile('501.bmp');
  try
    Image1.WrapMode := TImageWrapMode.iwStretch;
    //描画用のビットマップを生成
    Image1.Bitmap := TBitmap.Create(Trunc(Image1.Width), Trunc(Image1.Height));

    srcRect := RectF(0, 0, srcBitmap.Width, srcBitmap.Height);
    dstRect := RectF(0, 0, Image1.Width, Image1.Height);

    //ビットマップをTImageに描画
    //WrapModeをiwStretchにしているのでStretchDrawとなる
    Image1.Bitmap.Canvas.BeginScene();
    Image1.Bitmap.Canvas.DrawBitmap(srcBitmap, srcRect, dstRect, 1.0, False);
    Image1.Bitmap.Canvas.EndScene;
  finally
    FreeAndNil(srcBitmap);
  end;
end;

//=============================================================================
//  Form1とImage1のOnMouseDownイベント処理
//  TSelectionのTagObjectに移動りサイズ対象のコントロールを代入
//=============================================================================
procedure TForm1.Image1MouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Single);
var
  AControl : TControl;
begin
  if Button = TMouseButton.mbLeft then begin
    AControl := TControl(Sender);

    //現在の対象のコントロールのHitTestをTrueにしてマウスイベント捕捉可能に戻す
    if Selection1.TagObject <> nil then begin
      if AControl <> TControl(Selection1.TagObject) then begin
        TControl(Selection1.TagObject).HitTest := True;
      end;
      Selection1.TagObject := nil;
    end;

    if (AControl is TImage) or (AControl is TPanel) then begin
      //Selection1の位置とサイズを対象コントロールと同じにする
      Selection1.SetBounds(AControl.Position.X,
                           AControl.Position.Y,
                           AControl.Width,
                           AControl.Height);
      Selection1.Visible   := True;
      Selection1.TagObject := AControl;
      //対象コントロールでマウスイベントを捕捉しないでSelection1で捕捉する
      AControl.HitTest := False;

      //すぐに移動可能なように,Selection1を前面に移動してMouseDown実行
      Selection1.BringToFront;
      Selection1.MouseDown(TMouseButton.mbLeft, [], X, Y);
    end else begin
      Selection1.Visible := False;
    end;
  end;
end;

//=============================================================================
//  Selection1のOnMouseMoveイベント処理
//  対象コントロールの位置とサイズをSelection1と同じにする
//=============================================================================
procedure TForm1.Selection1MouseMove(Sender: TObject; Shift: TShiftState; X,
  Y: Single);
var
  Selection : TSelection;
begin
  Selection := TSelection(Sender);

  if Selection.TagObject <> nil then begin
    TControl(Selection.TagObject).SetBounds(Selection.Position.X,
                                            Selection.Position.Y,
                                            Selection.Width,
                                            Selection.Height);
  end;
end;

end.




09_FireMonkey によるコントロールの移動リサイズ - OnTrack


TSelection コンポーネントでは移動リサイズの検出に OnTrack イベントも利用可能です.
次のサンプルは,この OnTrack イベントを使用した例です.
OnTrack イベントには,OnMouseMove イベントとは違い,マウスカーソルの位置や Shift キーを検出するための引数はありません.



図16
設計時画面
  • 左から TImage, TPanel, TSelection
  • TPanel は色を変更している
図17
TPanel をリサイズ中

リスト7
TSelection の OnTrack イベントによるコントロールの移動リサイズ
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)
    Image1: TImage;
    Selection1: TSelection;
    Panel1: TPanel;
    StyleBook1: TStyleBook;
    procedure FormShow(Sender: TObject);
    procedure Image1MouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Single);
    procedure Selection1Track(Sender: TObject);
  private
    { private 宣言 }
  public
    { public 宣言 }
  end;

var
  Form1: TForm1;

implementation

{$R *.fmx}

//=============================================================================
//  フォーム表示開始時の処理
//  ビットマップ画像を読み込んでImage1に表示
//=============================================================================
procedure TForm1.FormShow(Sender: TObject);
var
  srcBitmap : TBitmap;
  srcRect   : TRectF;
  dstRect   : TRectF;
begin
  Selection1.Visible := False;

  srcBitmap := TBitmap.CreateFromFile('503.bmp');
  try
    Image1.WrapMode := TImageWrapMode.iwStretch;
    //描画用のビットマップを生成
    Image1.Bitmap := TBitmap.Create(Trunc(Image1.Width), Trunc(Image1.Height));

    srcRect := RectF(0, 0, srcBitmap.Width, srcBitmap.Height);
    dstRect := RectF(0, 0, Image1.Width, Image1.Height);

    //ビットマップをTImageに描画
    //WrapModeをiwStretchにしているのでStretchDrawとなる
    Image1.Bitmap.Canvas.BeginScene();
    Image1.Bitmap.Canvas.DrawBitmap(srcBitmap, srcRect, dstRect, 1.0, False);
    Image1.Bitmap.Canvas.EndScene;
  finally
    FreeAndNil(srcBitmap);
  end;
end;

//=============================================================================
//  Form1と他のコントロールOnMouseDownイベント処理
//  TSelectionのTagObjectに移動りサイズ対象のコントロールを代入
//=============================================================================
procedure TForm1.Image1MouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Single);
var
  AControl : TControl;
begin
  if Button = TMouseButton.mbLeft then begin
    AControl := TControl(Sender);

    //現在の対象のコントロールのHitTestをTrueにしてマウスイベント捕捉可能に戻す
    if Selection1.TagObject <> nil then begin
      if AControl <> TControl(Selection1.TagObject) then begin
        TControl(Selection1.TagObject).HitTest := True;
      end;
      Selection1.TagObject := nil;
    end;

    if (AControl is TImage) or (AControl is TPanel) then begin
      //Selection1の位置とサイズを対象コントロールと同じにする
      Selection1.SetBounds(AControl.Position.X,
                           AControl.Position.Y,
                           AControl.Width,
                           AControl.Height);
      Selection1.Visible   := True;
      Selection1.TagObject := AControl;
      //対象コントロールでマウスイベントを捕捉しないでSelection1で捕捉する
      AControl.HitTest := False;

      //すぐに移動可能なように,Selection1を前面に移動してMouseDown実行
      Selection1.BringToFront;
      Selection1.MouseDown(TMouseButton.mbLeft, [], X, Y);
    end else begin
      Selection1.Visible := False;
    end;
  end;
end;

//=============================================================================
//  Selection1のOnTrackイベント処理
//  対象コントロールの位置とサイズをSelection1と同じにする
//=============================================================================
procedure TForm1.Selection1Track(Sender: TObject);
var
  Selection : TSelection;
begin
  Selection := TSelection(Sender);
  if Selection.TagObject <> nil then begin
    TControl(Selection.TagObject).SetBounds(Selection.Position.X,
                                            Selection.Position.Y,
                                            Selection.Width,
                                            Selection.Height);
  end;
end;

end.