Delphi Programming / Object Pascal
サイトのトップページへ リンクのページへ ロゴマーク
[掲載 2009年03月01日] [更新 2012年10月18日]　Delphi サンプルプログラム集
152_WM_NCHITTEST とコントロールの移動リサイズ
動作確認等 Windows XP(SP3)    + Delphi XE Pro
Windows 7 U64(SP1) + Delphi XE Pro
152_MoveResize.zip　[5,178 KB]　2012年09月15日版 (EXE 同梱)



  • 2009年10月31日
  • [05_移動リサイズ可能な画像]を追加
  • 2010年01月11日
  • [05_移動リサイズ可能な画像]にチラツキ防止参考コードを追加
  • 2012年09月14日
  • チラつき防止コードを汎用的なコードに修正
  • コントロールの移動リサイズ関係コンポーネントの紹介記事を追加



WM_NCHITTEST によるコントロールの移動とリサイズ


[100_OnDragOver イベントを使用したコントロールのドラッグ] から [150_オブジェクトリストの保存 2] までのサンプルではコントロールをマウスドラッグで移動しています。
コントロールの移動は、WM_NCHITTEST メッセージを処理することでも可能です。このメッセージは、キャプションバー (タイトルバー) の無いフォームをマウスドラッグで移動したり、キャプションバー以外の場所で移動する際にも利用することがあります。

ただし、この方法は TWinControl の派生コントロールだけで使用できます。TGraphicControl では利用できません。また、移動リサイズの操作中はマウスカーソルは変更できません。マウス関係のメッセージやイベントも捕捉できません。WM_NCHITTEST メッセージは全てのマウス関係メッセージの前に発生します。必要であれば、マウス関係のメッセージ処理は、この WM_NCHITTEST メッセージ内で行うことになります。

フォームに配置したコントロールのメッセージを処理するわけですが、フォームには複数のコントロールを配置するのが普通です。そのため、どのコントロールが発生したメッセージなのかを判定しなければなりません。しかし、対象のコントロールを配置したフォームに WM_NCHITTEST メッセージ処理のコードを追加しても、対象のコントロールでは、このメッセージは受信できません。

そこで、本ページのサンプルでは、移動またはリサイズ可能なコンポーネントを作成しています。つまり、対象のコントロール (コンポーネント) の派生クラス (継承クラス) を作成します。
そうすると、そのコンポーネントだけのメッセージの処理ができます。また、必要であれば、イベントも定義して、外部から操作することも可能になります。

ただし、本ページのサンプルでは、それらのコンポーネントは実行時に生成して使用しています。もちろん、パッケージに登録して利用することもできるようにしています。


WM_NCHITTEST メッセージの戻り値が、次のように HICLIENT の時は、通常のマウスメッセージ処理となり、各種のマウスメッセージも、コントロールのマウスイベント処理も通常通り実行されるようになります。 


procedure TplMoveResizeMemo.WmNCHitTest(var msg: TWmNCHitTest);
begin
  inherited;

  msg.Result := HTCLIENT;
end;


[備考 1]
フォームに配置したコントロールの WM_NCHITTEST メッセージは、TApplication.OnMessage では捕捉することはできません。該当コントロールのサブクラス化、あるいは、ローカルフックで捕らえることになります。この意味もあって、コンポーネントにしてテストしています。

[備考 2]
移動リサイズ関係のコンポーネント類を紹介していますが、これらは必ずしも WM_NCHITTEST メッセージを使用しているわけではありません。




01_マウスドラッグによる移動


コントロールの移動だけのサンプルです。
移動だけを可能した、TMemo を作成して使用します。

このテストプログラムでは、対象コントロールの上にマウスカーソルがくると、クリックしなくてもそのコントロールにフォーカスが移動します。


図1
設計時画面
  • フォーカス移動のテスト用に TEdit を配置
図2
実行画面
  • マウスが TMemo の上にくるとフォーカス移動
  • マウスドラッグで移動する
  • 移動の枠(グラブハンドル)等の表示はない

リスト1
WM_NCHITTEST メッセージを使用したマウスドラッグによる移動 
unit MoveResize_TMemo1Unit;

interface

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

type
  TForm1 = class(TForm)
    Edit1: TEdit;
    procedure FormShow(Sender: TObject);
  private
    { Private 宣言 }
    AMoveMemo : TplMoveMemo;
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

//=============================================================================
//  コンポーネントの実行時生成
//  マウスドラッグで移動とりサイズが可能
//=============================================================================
procedure TForm1.FormShow(Sender: TObject);
begin
  AMoveMemo := TplMoveMemo.Create(Self);
  AMoveMemo.Parent := Self;
  AMoveMemo.Left   := 20;
  AMoveMemo.Top    := 50;
end;

end.


リスト2
マウスドラッグで移動可能な TMemo コンポーネントのソース 
unit plMoveMemo;

interface

uses
  Windows, Messages, SysUtils, Classes, StdCtrls;

type
  TplMoveMemo = class(TMemo)
  private
    { Private 宣言 }
  protected
    procedure WmNCHitTest(var msg: TWmNCHitTest); message WM_NCHITTEST;
    procedure WmSysCommand(var msg: TWmSysCommand); message WM_SYSCOMMAND;
  public
    Constructor Create(AOWner: TComponent); override;
    destructor Destroy; override;
  end;

procedure Register;

implementation

//=============================================================================
//  コンポーネントをコンポーネントパレットに登録する手続き
//=============================================================================
procedure Register;
begin
  RegisterComponents('plXRAY', [TplMoveMemo]);
end;

{ TMoveMemo }

//=============================================================================
//  Create処理
//  inheritedだけなので必要ないが、後の処理の追加のために実装しておく
//=============================================================================
constructor TplMoveMemo.Create(AOWner: TComponent);
begin
  inherited Create(AOwner);
  //初期化処理のコード
end;

//=============================================================================
//  Destroy処理
//  inheritedだけなので必要ないが、後の処理の追加のために実装しておく
//=============================================================================
destructor TplMoveMemo.Destroy;
begin
  //終了処理のコード
  inherited Destroy;
end;

//=============================================================================
//  WM_NCHITTESTは[現在マウスカーソルがある部分は何か]を決定する時に送られるメ
//  ッセージ
//  このメッセージの戻値(msg.Result)を変更することで動作を変える
//  HTCAPTION  キャプションを掴んだと思わせる
//             つまりドラッグで移動可能
//  HTLEFT     フォームの左端にマウスがあると思わせる
//             つまりマウスドラッグで横幅のサイズ変更が可能
//
//  WM_NCHITTESTをコントロールで実装した場合は、WM_LBUTTONDOWN等のメッセージは
//  無効となる。またカーソルの形状も強制的に変更となるため、操作中のカーソル形
//  状は変更できない(システムのカーソルを変更すれば可能かも知れない)
//=============================================================================
procedure TplMoveMemo.WmNCHitTest(var msg: TWmNCHitTest);
begin
  //継承元のメッセージの実行
  inherited;
  //これ以降のコードを実行しなければ通常のTMemoと同じ動作となる

  if not (csDesigning in ComponentState) then begin
    //クライアント領域がクリックされた場合
    if Msg.Result=htClient then begin
      //フォーカス移動(文字入力が可能な状態に)してキャプションバーだと思わせる
      SetFocus;
      msg.Result := HTCAPTION;
    end;
  end;
end;

//=============================================================================
//  WM_NCHITTESTメッセージの処理でコントロールのクライアント領域にマウスカーソ
//  ルがある時にキャプションバー(HTCAPTION)としてしまったので、それに対する処置
//  この処理がないとダブルクリックでAlign:=alClient;としたのと同じとなる
//=============================================================================
procedure TplMoveMemo.WmSysCommand(var msg: TWmSysCommand);
begin
  //CmdTypeにSC_MAXIMIZE(最大化要求)が含まれている時は何もしない
  if (msg.CmdType or SC_MAXIMIZE) = msg.CmdType then begin
  end else begin
    //通常通り
    inherited;
  end;
end;

end.



02_マウスドラッグによる移動とリサイズ


次は、移動とリサイズを可能にした TMemo コンポーネントです。マウス座標値を調査判定して、その位置により、WM_NCHITTEST の戻値を変更しています。


図3
設計時画面
  • フォーカス移動のテスト用に TEdit を配置
図4
実行画面
  • マウスが TMemo の上にくるとフォーカス移動
  • マウスドラッグで移動
  • クライアントの境界でリサイズ可能。カーソルは位置に応じて自動的に変わる

リスト3
WM_NCHITTEST メッセージを使用したコントロールの移動とリサイズ 
unit MoveResize_TMemo2Unit;

interface

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

type
  TForm1 = class(TForm)
    Edit1: TEdit;
    procedure FormShow(Sender: TObject);
  private
    { Private 宣言 }
    AMoveResizeMemo : TplMoveResizeMemo;
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

//=============================================================================
//  コンポーネントの実行時生成
//  マウスドラッグで移動とりサイズが可能
//=============================================================================
procedure TForm1.FormShow(Sender: TObject);
begin
  AMoveResizeMemo := TplMoveResizeMemo.Create(Self);
  AMoveResizeMemo.Parent := Self;
  AMoveResizeMemo.Left   := 20;
  AMoveResizeMemo.Top    := 50;
end;

end.


リスト4
マウスドラッグで移動リサイズ可能な TMemo コンポーネントのソース 
unit plMoveResizeMemo;

interface

uses
  Windows, Messages, SysUtils, Classes, StdCtrls;

type
  TplMoveResizeMemo = class(TMemo)
  private
    { Private 宣言 }
  protected
    procedure WmNCHitTest(var msg: TWmNCHitTest); message WM_NCHITTEST;
    procedure WmSysCommand(var msg: TWmSysCommand); message WM_SYSCOMMAND;
  public
    Constructor Create(AOWner: TComponent); override;
    destructor Destroy; override;
  end;

procedure Register;

implementation

//=============================================================================
//  コンポーネントをコンポーネントパレットに登録する手続き
//=============================================================================
procedure Register;
begin
  RegisterComponents('plXRAY', [TplMoveResizeMemo]);
end;

{ TMoveResizeMemo }

//=============================================================================
//  Create処理
//  inheritedだけなので必要ないが、後の処理の追加のために実装しておく
//=============================================================================
constructor TplMoveResizeMemo.Create(AOWner: TComponent);
begin
  inherited Create(AOwner);
  //初期化処理のコード
end;

//=============================================================================
//  Destroy処理
//  inheritedだけなので必要ないが、後の処理の追加のために実装しておく
//=============================================================================
destructor TplMoveResizeMemo.Destroy;
begin
  //終了処理のコード
  inherited Destroy;
end;

//=============================================================================
//  WM_NCHITTESTは[現在マウスカーソルがある部分は何か]を決定する時に送られるメ
//  ッセージ
//  このメッセージの戻値(msg.Result)を変更することで動作を変える
//  HTCAPTION  キャプションを掴んだと思わせる
//             つまりドラッグで移動可能
//  HTLEFT     フォームの左端にマウスがあると思わせる
//             つまりマウスドラッグで横幅のサイズ変更が可能
//
//  ここではクライアント領域の境の5ドット分内にマウスが来た時にその境界とする
//  まずマウス位置の上下左右を変数に代入し、その組合せで判定する
//
//  WM_NCHITTESTをコントロールで実装した場合は、WM_LBUTTONDOWN等のメッセージは
//  無効となる。またカーソルの形状も強制的に変更となるため、操作中のカーソル形
//  状は変更できない(システムのカーソルを変更すれば可能かも知れない)
//=============================================================================
procedure TplMoveResizeMemo.WmNCHitTest(var msg: TWmNCHitTest);
const
  mptLeft   = $01;
  mptTop    = $02;
  mptRight  = $04;
  mptBottom = $08;

var
  APos    : TPoint;
  PosFlag : Byte;
begin
  //継承元のメッセージの実行
  inherited;
  //これ以降のコードを実行しなければ通常のTMemoと同じ動作となる
  if (csDesigning in ComponentState) then exit;

  //クライアント領域でのマウス位置を取得
  APos := ScreenToClient(Point(msg.XPos, msg.YPos));

  PosFlag := $00;
  //左端から5ドット未満
  if (APos.X < 5) then PosFlag := PosFlag or mptLeft;
  //上端から5ドット未満
  if (APos.Y < 5) then PosFlag := PosFlag or mptTop;
  //右端から5ドット未満
  if (ClientWidth - APos.X) < 5 then PosFlag := PosFlag or mptRight;
  //下端から5ドット未満
  if (ClientHeight - APos.Y) < 5 then PosFlag := PosFlag or mptBottom;

  case PosFlag of
    mptLeft            : msg.Result := HTLEFT;
    mptTop             : msg.Result := HTTOP;
    mptTop+mptLeft     : msg.Result := HTTOPLEFT;
    mptRight           : msg.Result := HTRIGHT;
    mptTop+mptRight    : msg.Result := HTTOPRIGHT;
    mptBottom          : msg.Result := HTBOTTOM;
    mptBottom+mptLeft  : msg.Result := HTBOTTOMLEFT;
    mptBottom+mptRight : msg.Result := HTBOTTOMRIGHT;
  else
    SetFocus;
    msg.Result := HTCAPTION;
  end;
end;

//=============================================================================
//  WM_NCHITTESTメッセージの処理でコントロールのクライアント領域にマウスカーソ
//  ルがある時にキャプションバー(HTCAPTION)としてしまったので、それに対する処置
//  この処理がないとダブルクリックでAlign:=alClient;としたのと同じとなる
//=============================================================================
procedure TplMoveResizeMemo.WmSysCommand(var msg: TWmSysCommand);
begin
  //CmdTypeにSC_MAXIMIZE(最大化要求)が含まれている時は何もしない
  if (msg.CmdType or SC_MAXIMIZE) = msg.CmdType then begin
  end else begin
    //通常通り
    inherited;
  end;
end;

end.



03_パネルの移動とリサイズ


TCustomPanel を継承したコンポーネントも作成してテストしてみました。


図5
実行画面

リスト5
移動リサイズ可能な TPanel のテスト 
unit MoveResize_TPanelUnit;

interface

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

type
  TForm1 = class(TForm)
    procedure FormShow(Sender: TObject);
  private
    { Private 宣言 }
    AMoveResizePanel : TplMoveResizePanel;
  public
    { Public 宣言 }

  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

//=============================================================================
//  コンポーネントの実行時生成
//  マウスドラッグで移動とりサイズが可能
//=============================================================================
procedure TForm1.FormShow(Sender: TObject);
begin
  AMoveResizePanel := TplMoveResizePanel.Create(Self);
  AMoveResizePanel.Parent := Self;
  AMoveResizePanel.Left   := 20;
  AMoveResizePanel.Top    := 50;
  AMoveResizePanel.Color  := clYellow;
  //このコードがないとColorプロパティが反映されない(テーマが有効な場合)
  AMoveResizePanel.ParentBackground := False;
end;

end.


リスト6
マウスドラッグで移動可能な TPanel コンポーネントのソース 
unit plMoveResizePanel;

interface

uses
  Windows, Messages, SysUtils, Classes, StdCtrls, ExtCtrls;

type
  TplMoveResizePanel = class(TCustomPanel)
  private
    { Private 宣言 }
  protected
    procedure WmNCHitTest(var msg: TWmNCHitTest); message WM_NCHITTEST;
    procedure WmSysCommand(var msg: TWmSysCommand); message WM_SYSCOMMAND;
  public
    constructor Create(AOWner: TComponent); override;
    destructor Destroy; override;
  published
    property Color;
  end;

procedure Register;

implementation

//=============================================================================
//  コンポーネントをコンポーネントパレットに登録する手続き
//=============================================================================
procedure Register;
begin
  RegisterComponents('plXRAY', [TplMoveResizePanel]);
end;

{ TMoveResizePanel }

//=============================================================================
//  Create処理
//=============================================================================
constructor TplMoveResizePanel.Create(AOWner: TComponent);
begin
  inherited Create(AOwner);
end;

//=============================================================================
//  Destroy処理
//=============================================================================
destructor TplMoveResizePanel.Destroy;
begin
  inherited Destroy;
end;

//=============================================================================
//  WM_NCHITTESTは[現在マウスカーソルがある部分は何か]を決定する時に送られるメ
//  ッセージ
//  このメッセージの戻値(msg.Result)を変更することで動作を変える
//  HTCAPTION  キャプションを掴んだと思わせる
//             つまりドラッグで移動可能
//  HTLEFT     フォームの左端にマウスがあると思わせる
//             つまりマウスドラッグで横幅のサイズ変更が可能
//
//  ここではクライアント領域の境の5ドット分内にマウスが来た時にその境界とする
//  まずマウス位置の上下左右を変数に代入し、その組合せで判定する
//
//  WM_NCHITTESTをコントロールで実装した場合は、WM_LBUTTONDOWN等のメッセージは
//  無効となる。またカーソルの形状も強制的に変更となるため、操作中のカーソル形
//  状は変更できない(システムのカーソルを変更すれば可能かも知れない)
//=============================================================================
procedure TplMoveResizePanel.WmNCHitTest(var msg: TWmNCHitTest);
const
  mptLeft   = $01;
  mptTop    = $02;
  mptRight  = $04;
  mptBottom = $08;

var
  APos    : TPoint;
  PosFlag : Byte;
begin
  //継承元のメッセージの実行
  inherited;
  //これ以降のコードを実行しなければ通常のTPanelと同じ動作となる
  if (csDesigning in ComponentState) then exit;

  //クライアント領域でのマウス位置を取得
  APos := ScreenToClient(Point(msg.XPos, msg.YPos));

  PosFlag := $00;
  //左端から5ドット未満
  if (APos.X < 5) then PosFlag := PosFlag or mptLeft;
  //上端から5ドット未満
  if (APos.Y < 5) then PosFlag := PosFlag or mptTop;
  //右端から5ドット未満
  if (ClientWidth - APos.X) < 5 then PosFlag := PosFlag or mptRight;
  //下端から5ドット未満
  if (ClientHeight - APos.Y) < 5 then PosFlag := PosFlag or mptBottom;

  case PosFlag of
    mptLeft            : msg.Result := HTLEFT;
    mptTop             : msg.Result := HTTOP;
    mptTop+mptLeft     : msg.Result := HTTOPLEFT;
    mptRight           : msg.Result := HTRIGHT;
    mptTop+mptRight    : msg.Result := HTTOPRIGHT;
    mptBottom          : msg.Result := HTBOTTOM;
    mptBottom+mptLeft  : msg.Result := HTBOTTOMLEFT;
    mptBottom+mptRight : msg.Result := HTBOTTOMRIGHT;
  else
    msg.Result := HTCAPTION;
  end;
end;

//=============================================================================
//  WM_NCHITTESTメッセージの処理でコントロールのクライアント領域にマウスカーソ
//  ルがある時にキャプションバー(HTCAPTION)としてしまったので、それに対する処置
//  この処理がないとダブルクリックでAlign:=alClient;としたのと同じとなる
//=============================================================================
procedure TplMoveResizePanel.WmSysCommand(var msg: TWmSysCommand);
begin
  //CmdTypeにSC_MAXIMIZE(最大化要求)が含まれている時は何もしない
  if (msg.CmdType or SC_MAXIMIZE) = msg.CmdType then begin
  end else begin
    //通常通り
    inherited;
  end;
end;

end.



04_TImage は WM_NCHITTEST メッセージ では移動リサイズ不可


TImage やTShape は TGraphicControl の派生コンポーネントです。したがって WM_NCHITTEST メッセージで移動リサイズの処理はできません。このことを確認するためのテストプログラムです。


図6
実行画面
  • 実際には移動もリサイズも不可

リスト7
TImage は WM_NCHITTEST メッセージ で移動リサイズできないことを確認するテスト 
unit MoveResize_TImageUnit;

interface

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

type
  TForm1 = class(TForm)
    procedure FormShow(Sender: TObject);
  private
    { Private 宣言 }
    AMoveResizeImage : TplMoveResizeImage;
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

//=============================================================================
//  コンポーネントの実行時生成
//  マウスドラッグで移動とりサイズをテスト
//  実際にはできない
//=============================================================================
procedure TForm1.FormShow(Sender: TObject);
begin
  AMoveResizeImage := TplMoveResizeImage.Create(Self);
  AMoveResizeImage.Parent := Self;
  AMoveResizeImage.Left   := 20;
  AMoveResizeImage.Top    := 30;
  AMoveResizeImage.Picture.LoadFromFile('TestImage.bmp');
  AMoveResizeImage.Stretch := True;
end;

end.


リスト8
WM_NCHITTESTメッセージのコードを追加したTImageの継承コンポーネントのソース
実際には動作しない 
unit plMoveResizeImage;

interface

uses
  Windows, Messages, SysUtils, Classes, StdCtrls, Graphics,  ExtCtrls;

type
  TplMoveResizeImage = class(TImage)
  private
    { Private 宣言 }
  protected
    procedure WmNCHitTest(var msg: TWmNCHitTest); message WM_NCHITTEST;
    procedure WmSysCommand(var msg: TWmSysCommand); message WM_SYSCOMMAND;
  public
    constructor Create(AOWner: TComponent); override;
    destructor Destroy; override;
  end;

procedure Register;

implementation

//=============================================================================
//  コンポーネントをコンポーネントパレットに登録する手続き
//=============================================================================
procedure Register;
begin
  RegisterComponents('plXRAY', [TplMoveResizeImage]);
end;

{ TMoveResizeImage }

//=============================================================================
//  Create処理
//  inheritedだけなので必要ないが、後での処理の追加のために実装しておく
//=============================================================================
constructor TplMoveResizeImage.Create(AOWner: TComponent);
begin
  inherited Create(AOwner);
end;

//=============================================================================
//  Destroy処理
//  inheritedだけなので必要ないが、後での処理の追加のために実装しておく
//=============================================================================
destructor TplMoveResizeImage.Destroy;
begin
  inherited Destroy;
end;

//=============================================================================
//  WM_NCHITTESTは[現在マウスカーソルがある部分は何か]を決定する時に送られるメ
//  ッセージ
//  このメッセージの戻値(msg.Result)を変更することで動作を変える
//  HTCAPTION  キャプションを掴んだと思わせる
//             つまりドラッグで移動可能
//  HTLEFT     フォームの左端にマウスがあると思わせる
//             つまりマウスドラッグで横幅のサイズ変更が可能
//
//  ここではクライアント領域の境の5ドット分内にマウスが来た時にその境界とする
//  まずマウス位置の上下左右を変数に代入し、その組合せで判定する
//
//  WM_NCHITTESTをコントロールで実装した場合は、WM_LBUTTONDOWN等のメッセージは
//  無効となる。またカーソルの形状も強制的に変更となるため、ドラッグ中のカーソ
//  ル形状は変更できない(システムのカーソルを変更すれば可能かも知れない)
//=============================================================================
procedure TplMoveResizeImage.WmNCHitTest(var msg: TWmNCHitTest);
const
  mptLeft   = $01;
  mptTop    = $02;
  mptRight  = $04;
  mptBottom = $08;

var
  APos    : TPoint;
  PosFlag : Byte;
begin
  //継承元のメッセージの実行
  inherited;
  //これ以降のコードを実行しなければ通常のTPanelと同じ動作となる
  if (csDesigning in ComponentState) then exit;

  //クライアント領域でのマウス位置を取得
  APos := ScreenToClient(Point(msg.XPos, msg.YPos));

  PosFlag := $00;
  //左端から5ドット未満
  if (APos.X < 5) then PosFlag := PosFlag or mptLeft;
  //上端から5ドット未満
  if (APos.Y < 5) then PosFlag := PosFlag or mptTop;
  //右端から5ドット未満
  if (ClientWidth - APos.X) < 5 then PosFlag := PosFlag or mptRight;
  //下端から5ドット未満
  if (ClientHeight - APos.Y) < 5 then PosFlag := PosFlag or mptBottom;

  case PosFlag of
    mptLeft            : msg.Result := HTLEFT;
    mptTop             : msg.Result := HTTOP;
    mptTop+mptLeft     : msg.Result := HTTOPLEFT;
    mptRight           : msg.Result := HTRIGHT;
    mptTop+mptRight    : msg.Result := HTTOPRIGHT;
    mptBottom          : msg.Result := HTBOTTOM;
    mptBottom+mptLeft  : msg.Result := HTBOTTOMLEFT;
    mptBottom+mptRight : msg.Result := HTBOTTOMRIGHT;
  else
    msg.Result := HTCAPTION;
  end;
end;

//=============================================================================
//  WM_NCHITTESTメッセージの処理でコントロールのクライアント領域にマウスカーソ
//  ルがある時にキャプションバー(HTCAPTION)としてしまったので、それに対する処置
//  この処理がないとダブルクリックでAlign:=alClient;としたのと同じとなる
//=============================================================================
procedure TplMoveResizeImage.WmSysCommand(var msg: TWmSysCommand);
begin
  //CmdTypeにSC_MAXIMIZE(最大化要求)が含まれている時は何もしない
  if (msg.CmdType or SC_MAXIMIZE) = msg.CmdType then begin
  end else begin
    //通常通り
    inherited;
  end;
end;

end.



05_移動リサイズ可能な画像


TPanel は他のコンポーネントのコンテナとなるコントロールです。ここに TImage を乗せ、TImage に画像や図形を表示すれば、見かけ上画像や図形が移動リサイズできているよう見えます。
TImage には、画像操作のためのいろいろいなメソッドやプロパティが実装されています。Timage プロパティを持つコンポーネントはこの点では便利です。

TPanel は、private 部に Canvas プロパティがあります。Paint メソッドを override したメソッド内に画像描画のコードを追加して、画像表示機能付きの TPanel とすることもできます。
[画像表示機能付き縦横両用ラベルコンポーネント]では、この方法で TLabel に画像を表示するようにしています。
また、[160] [08-01_TPanel の継承クラスの Paint メソッドで画像を描画] では、TPanel を実行時に生成して画像を表示しています。


図7
実行画面
  • 画像 (TIamge) の移動リサイズが可能

リスト9
WM_NCHITTEST メッセージを使用した、移動リサイズ可能な TImage コンポのテスト 
unit MoveResize_TPanelUnit;

interface

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

type
  TForm1 = class(TForm)
    procedure FormShow(Sender: TObject);
  private
    { Private 宣言 }
    AMoveResizePanel : TplMoveResizePanelEx;
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

//=============================================================================
//  コンポーネントの実行時生成
//  マウスドラッグで移動とりサイズが可能
//=============================================================================
procedure TForm1.FormShow(Sender: TObject);
begin
  AMoveResizePanel := TplMoveResizePanelEx.Create(Self);
  with AMoveResizePanel do begin
    Parent := Self;
    Left   := 20;
    Top    := 50;
    Width  := 130;
    Height := 130;
    DoubleBuffered := True;
  end;

  with AMoveResizePanel.Image do begin
    Picture.LoadFromFile('TestImage.bmp');
    Stretch := True;
  end;
end;

end.


リスト10
コンポーネントのソース
移動リサイズ可能な TImageコンポ。実際には TPanel を移動リサイズする
移動リサイズの可否のプロパティを実装した方がいいかもしれない 
unit plMoveResizePanelEx;

interface

uses
  Windows, Messages, SysUtils, Classes, StdCtrls, ExtCtrls, Controls;

type
  TplMoveResizePanelEx = class(TCustomPanel)
  private
    { Private 宣言 }
    FImage : TImage;
    procedure SetFImage(const Value: TImage);
  protected
    procedure SetParent(AParent: TWinControl); override;
    procedure WmNCHitTest(var msg: TWmNCHitTest); message WM_NCHITTEST;
    procedure WmSysCommand(var msg: TWmSysCommand); message WM_SYSCOMMAND;
    procedure WMEraseBkgnd(var Message: TWMEraseBkgnd); message WM_ERASEBKGND;
  public
    constructor Create(AOWner: TComponent); override;
    destructor Destroy; override;
    property Image : TImage read FImage write SetFImage;

  published
    property Color;
  end;

procedure Register;

implementation

//=============================================================================
//  コンポーネントをコンポーネントパレットに登録する手続き
//=============================================================================
procedure Register;
begin
  RegisterComponents('plXRAY', [TplMoveResizePanelEx]);
end;

{ TMoveResizePanelEx }

//=============================================================================
//  Create処理
//=============================================================================
constructor TplMoveResizePanelEx.Create(AOWner: TComponent);
begin
  inherited Create(AOwner);
end;

//=============================================================================
//  Destroy処理
//=============================================================================
destructor TplMoveResizePanelEx.Destroy;
begin
  inherited Destroy;
end;

//=============================================================================
//  ParentがSetされたらTImageを配置
//=============================================================================
procedure TplMoveResizePanelEx.SetParent(AParent: TWinControl);
begin
  inherited;

  if Parent = nil then exit;

  //既に存在すれば以下は不要
  //SetParentは破棄の時など何回も呼ばれるので条件判断が必要
  if FImage=nil then begin
    FImage        := TImage.Create(Self);
    FImage.Parent := Self;
    FImage.Align  := alClient;
  end;
end;

//=============================================================================
//  オブジェクトのプロパティの書込みはメソッドを実装してAssignする
//=============================================================================
procedure TplMoveResizePanelEx.SetFImage(const Value: TImage);
begin
  FImage.Assign(Value);
end;

//=============================================================================
//  WM_NCHITTESTは[現在マウスカーソルがある部分は何か]を決定する時に送られるメ
//  ッセージ
//  このメッセージの戻値(msg.Result)を変更することで動作を変える
//  HTCAPTION  キャプションを掴んだと思わせる
//             つまりドラッグで移動可能
//  HTLEFT     フォームの左端にマウスがあると思わせる
//             つまりマウスドラッグで横幅のサイズ変更が可能
//
//  ここではクライアント領域の境の5ドット分内にマウスが来た時にその境界とする
//  まずマウス位置の上下左右を変数に代入し、その組合せで判定する
//
//  WM_NCHITTESTをコントロールで実装した場合は、WM_LBUTTONDOWN等のメッセージは
//  無効となる。またカーソルの形状も強制的に変更となるため、操作中のカーソル形
//  状は変更できない(システムのカーソルを変更すれば可能かも知れない)
//=============================================================================
procedure TplMoveResizePanelEx.WmNCHitTest(var msg: TWmNCHitTest);
const
  mptLeft   = $01;
  mptTop    = $02;
  mptRight  = $04;
  mptBottom = $08;

var
  APos    : TPoint;
  PosFlag : Byte;
begin
  //継承元のメッセージを実行
  inherited;
  //これ以降のコードを実行しなければ通常のTPanelと同じ動作となる
  if (csDesigning in ComponentState) then exit;

  //クライアント領域でのマウス位置を取得
  APos := ScreenToClient(Point(msg.XPos, msg.YPos));

  PosFlag := $00;
  //左端から5ドット未満
  if (APos.X < 5) then PosFlag := PosFlag or mptLeft;
  //上端から5ドット未満
  if (APos.Y < 5) then PosFlag := PosFlag or mptTop;
  //右端から5ドット未満
  if (ClientWidth - APos.X) < 5 then PosFlag := PosFlag or mptRight;
  //下端から5ドット未満
  if (ClientHeight - APos.Y) < 5 then PosFlag := PosFlag or mptBottom;

  case PosFlag of
    mptLeft            : msg.Result := HTLEFT;
    mptTop             : msg.Result := HTTOP;
    mptTop+mptLeft     : msg.Result := HTTOPLEFT;
    mptRight           : msg.Result := HTRIGHT;
    mptTop+mptRight    : msg.Result := HTTOPRIGHT;
    mptBottom          : msg.Result := HTBOTTOM;
    mptBottom+mptLeft  : msg.Result := HTBOTTOMLEFT;
    mptBottom+mptRight : msg.Result := HTBOTTOMRIGHT;
  else
    msg.Result := HTCAPTION;
  end;
end;

//=============================================================================
//  WM_NCHITTESTメッセージの処理でコントロールのクライアント領域にマウスカーソ
//  ルがある時にキャプションバー(HTCAPTION)としてしまったので、それに対する処置
//  この処理がないとダブルクリックでAlign:=alClient;としたのと同じとなる
//=============================================================================
procedure TplMoveResizePanelEx.WmSysCommand(var msg: TWmSysCommand);
begin
  //CmdTypeにSC_MAXIMIZE(最大化要求)が含まれている時は何もしない
  if (msg.CmdType or SC_MAXIMIZE) = msg.CmdType then begin
  end else begin
    //通常通り
    inherited;
  end;
end;

//=============================================================================
//  WM_ERASEBKGNDメッセージ処理
//  何も描画しない
//  本サンプルでは、TPanel上にに配置したTImage に画像をalClientで描画しているの
//  で、TPanelの描画は不要
//  画像に透明部分がある時に、TImage.Transparent := True;にすると正常に描画され
//  ない。別の処理が必要となる。別の処理は、添付のサンプルプログラムを参照
//=============================================================================
procedure TplMoveResizePanelEx.WMEraseBkgnd(var Message: TWMEraseBkgnd);
begin
//
end;

end.



06_TPanel の描画チラつきを抑制する汎用的なコード


上のサンプルプログラムでは、TPanel の DoubleBuffered プロパティを True にしてもチラつきを防止することはできません。そこで、次のように WM_ERASEBKGND メッセージでを実装し、バックグラウンドの描画をしないようにしています。 


procedure TplMoveResizePanelEx.WMEraseBkgnd(var Message: TWMEraseBkgnd);
begin
//
end;


また、WM_ERASEBKGND メッセージのかわりに、コンポーネントのスタイルに csOpaque を含めることでもチラつきを防止できます。 


constructor TplPicturePanel.Create(AOWner: TComponent);
begin
  inherited Create(AOwner);

  ControlStyle := ControlStyle + [csOpaque];
  DoubleBuffered := True;
end;


上のサンプルではこのコードでチラつきを防止できますが、TImage の Transparent を True にすると、ビットマップの透過色の部分が描画されず、黒くなってしまいます。

一般に、TPanel の上に他のコントロールを配置した場合、TPanel を移動リサイズすると、チラつきが発生します。このチラつきは、DoubleBuffered や WM_ERASEBKGND メッセージの処理だけでは抑えることができないことがあります。河邦 正さんが作成した「TImage 等のちらつきを効率良く抑制する」というサンプルコードがあります。このコードを使用するとこの問題を回避できます。
このコードを使用したサンプルも添付しておきました。

このコードは、TPanel にコントロールを配置して使用する場合に有効です。この後の [画像表示機能付き TPanel] のように、TPanel の内部で描画コードを実行するような場合には、このままでは正常に動作しません。


リスト11
チラツキを抑制するための汎用的な処理コード 
//=============================================================================
//  WM_PAINTメッセージ処理
//  ちらつき防止用
//  旧Nifty FDelphi １６番会議室「玉石混淆みんなで作るSample蔵」の
//  河邦 正 さんのまコードを借用
//=============================================================================
procedure TplMoveResizePanelEx.WMPaint(var Message: TWMPaint);
var
  PStruct     : TPaintStruct;
  AWidth      : Integer;
  AHeigth     : Integer;
  DC          : HDC;
  bmp         : HBITMAP;
  bmpOld      : HBITMAP;
  i           : Integer;
  Count       : Integer;
  SaveDCIndex : Integer;
begin
  if Message.DC <> 0 then begin
    inherited;
  end else begin
    BeginPaint(Handle, PStruct);
    try
      AWidth  := PStruct.rcPaint.Right  - PStruct.rcPaint.Left;
      AHeigth := PStruct.rcPaint.Bottom - PStruct.rcPaint.Top;
      DC      := GetDC(HWND(0));
      bmp     := CreateCompatibleBitmap(DC, AWidth, AHeigth);

      ReleaseDC(HWND(0), DC);
      try
        Message.DC := CreateCompatibleDC(HDC(0));
        try
          bmpOld := SelectObject(Message.DC, bmp);

          SetWindowOrgEx(Message.DC, PStruct.rcPaint.Left, PStruct.rcPaint.Top, nil);
          FillRect(Message.DC, PStruct.rcPaint, Brush.Handle);

          Count := ControlCount;
          for i := 0 to Count - 1 do begin
            if Controls[i] is TWinControl then break;

            if Controls[i].Visible and
                RectVisible(PStruct.hdc, Controls[i].BoundsRect) then begin
              SaveDCIndex := SaveDC(Message.DC);
              OffsetWindowOrgEx  (Message.DC,
                                  -Controls[i].Left,
                                  -Controls[i].Top,
                                  nil);
              IntersectClipRect  (Message.DC,
                                  0,
                                  0,
                                  Controls[i].Width,
                                  Controls[i].Height);
              Controls[i].Perform(WM_PAINT, Message.DC, 0);
              RestoreDC(Message.DC, SaveDCIndex);
            end;
          end;

          BitBlt(PStruct.hdc,
                 PStruct.rcPaint.Left,
                 PStruct.rcPaint.Top,
                 AWidth,
                 AHeigth,
                 Message.DC,
                 PStruct.rcPaint.Left,
                 PStruct.rcPaint.Top,
                 SRCCOPY);

          SelectObject(Message.DC, bmpOld);
        finally
          DeleteDC(Message.DC);
          Message.DC := 0;
        end;
      finally
        DeleteObject(bmp);
      end;
    finally
      EndPaint(Handle, PStruct);
    end;
  end;
end;

//=============================================================================
//  WM_ERASEBKGNDメッセージ処理
//  このメッセージで何も処理しなければちらつかないが、このコントロール上の描画
//  が正常に実行されない
//  そこで背景を該当コントロールのBrushハンドルで塗り潰す
//  本サンプルでは、何もない空のコードでもよい
//=============================================================================
procedure TplMoveResizePanelEx.WMEraseBkgnd(var Message: TWMEraseBkgnd);
var
  Count : Integer;
  i     : Integer;
begin
  Count := ControlCount - 1;
  for i := 0 to Count do begin
    if Controls[i] is TWinControl then begin
      if Controls[i].Visible then begin
        FillRect(Message.DC,
                 TWinControl(Controls[i]).BoundsRect,
                 TWinControl(Controls[i]).Brush.Handle);
      end;
    end;
  end;
end;



07_画像表示機能付き TPanel


TPanel は、private 部に Canvas プロパティがあります。そこで、Paint メソッドを override したメソッド内に画像描画のコードを追加して、画像表示機能付きの TPanel を作成してみました。
TPanel は透過しないので、背景に模様を描いたり、枠を表示する等、ある意味便利です。写真等の画像表示には向いているかも知れません。

[画像表示機能付き縦横両用ラベルコンポーネント] も、この方法で TLabel に画像を表示するようにしています。TLabel は TGraphicControl の派生コンポーネントです。背景を透過できますが、他のコントロール、TWinControl の前面には表示できません。

このままでは、リサイズの際に「マウスで掴む」位置の判定が困難です。実用的にするには、ラバーバンドやグラブハンドルの表示が必要でしょう。



図8
実行画面
  • TPanel の Canvas に画像を描画
  • 枠線も表示してみた

リスト12
画像表示機能付き TPanel コンポーネントのテスト 
unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    procedure FormShow(Sender: TObject);
  private
    { Private 宣言 }
    PicturePanel : TplPicturePanel;
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

//=============================================================================
//  コンポーネントの実行時生成
//  マウスドラッグで移動とりサイズが可能
//=============================================================================
procedure TForm1.FormShow(Sender: TObject);
begin
  Caption := '画像表示機能付き TPanel';

  PicturePanel := TplPicturePanel.Create(Self);
  PicturePanel.Parent := Self;
  PicturePanel.Color  := clWhite;
  PicturePanel.SetBounds(50, 50, 150, 150);

  PicturePanel.Picture.LoadFromFile('503.bmp');
  PicturePanel.Picture.Bitmap.Transparent := True;
end;

end.


リスト13
画像表示機能付き TPanel コンポーネント 
unit plPicturePanel;       
interface

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

type
  TplPicturePanel = class(TCustomPanel)
  private
    { Private 宣言 }
    FPicture: TPicture;
    procedure SetPicture(const Value: TPicture);
  protected
    procedure WmNCHitTest(var msg: TWmNCHitTest); message WM_NCHITTEST;
    procedure WmSysCommand(var msg: TWmSysCommand); message WM_SYSCOMMAND;
    procedure Paint; override;
    procedure WMEraseBkgnd(var Message: TWMEraseBkgnd); message WM_ERASEBKGND;
  public
    constructor Create(AOWner: TComponent); override;
    destructor Destroy; override;
  published
    property Anchors;
    property Align;
    property BevelWidth;
    property BevelOuter;
    property BevelKind;
    property BevelInner;
    property BevelEdges;
    property Color;
    property ShowHint;
    property PopupMenu;
    property Visible;
    property OnDragOver;
    property OnEnter;
    property OnExit;
    property OnDragDrop;
    property OnDblClick;
    property OnMouseWheelUp;
    property OnMouseWheelDown;
    property OnMouseWheel;
    property OnMouseUp;
    property OnMouseLeave;
    property OnMouseEnter;
    property OnMouseDown;
    property OnResize;
    property Picture : TPicture read FPicture write SetPicture;
  end;

procedure Register;

implementation

//=============================================================================
//  コンポーネントをコンポーネントパレットに登録する手続き
//=============================================================================
procedure Register;
begin
  RegisterComponents('plXRAY', [TplPicturePanel]);
end;

{ TplPicturePanel }

//=============================================================================
//  Create処理
//=============================================================================
constructor TplPicturePanel.Create(AOWner: TComponent);
begin
  inherited Create(AOwner);

  Brush.Style := bsSolid;
  BorderStyle := bsNone;
  Color       := clBtnFace;
  FPicture    := TPicture.Create;

  //ちらつき防止。このコンポではWM_ERASEBKGNDと併用して防止
  DoubleBuffered := True;
end;

//=============================================================================
//  Destroy処理
//=============================================================================
destructor TplPicturePanel.Destroy;
begin
  FPicture.Free;
  inherited Destroy;
end;

//=============================================================================
//  Pictureプロパティの設定用メソッド
//=============================================================================
procedure TplPicturePanel.SetPicture(const Value: TPicture);
begin
  if Value <> nil then begin
    FPicture.Assign(Value);
    Repaint;
  end;
end;

//=============================================================================
//  Paintメソッド処理
//  描画が必要になると自動的に実行されるメソッド
//  コンポの描画用のイベントを定義し、このPaintメソッド内でそのイベントのコード
//  を実行するようにすれば、いろいろな描画コードに対応でき、汎用的になる
//=============================================================================
procedure TplPicturePanel.Paint;
var
  ARect : TRect;
begin
  inherited;

  //背景を塗り潰す
  Canvas.Brush.Color := Color;
  Canvas.Brush.Style := bsSolid;
  Canvas.FillRect(ClientRect);

  if FPicture <> nil then begin
    Canvas.StretchDraw(ClientRect, FPicture.Graphic);

    Canvas.Font.Size  := 13;
    Canvas.Font.Color := clBlue;
    SetBkMode(Canvas.Handle, TRANSPARENT);
    Canvas.TextOut(10, 10, '画像表示機能付きパネル');
  end;
  //ビットマップのTransparentをTrueにすると、マウスで掴む位置の判定が困難と
  //なるので、枠線を描画。つまりラバーバンド
  Canvas.Brush.Color := clBlack;
  Canvas.FrameRect(ClientRect);
end;

//=============================================================================
//  WM_NCHITTESTは[現在マウスカーソルがある部分は何か]を決定する時に送られるメ
//  ッセージ
//  このメッセージの戻値(msg.Result)を変更することで動作を変える
//  HTCAPTION  キャプションを掴んだと思わせる
//             つまりドラッグで移動可能
//  HTLEFT     フォームの左端にマウスがあると思わせる
//             つまりマウスドラッグで横幅のサイズ変更が可能
//
//  ここではクライアント領域の境の5ドット分内にマウスが来た時にその境界とする
//  まずマウス位置の上下左右を変数に代入し、その組合せで判定する
//
//  WM_NCHITTESTをコントロールで実装した場合は、WM_LBUTTONDOWN等のメッセージは
//  無効となる。またカーソルの形状も強制的に変更となるため、操作中のカーソル形
//  状は変更できない(システムのカーソルを変更すれば可能かも知れない)
//=============================================================================
procedure TplPicturePanel.WmNCHitTest(var msg: TWmNCHitTest);
const
  mptLeft   = $01;
  mptTop    = $02;
  mptRight  = $04;
  mptBottom = $08;

var
  APos    : TPoint;
  PosFlag : Byte;
begin
  //継承元のメッセージの実行
  inherited;
  //これ以降のコードを実行しなければ通常のTPanelと同じ動作となる
  if (csDesigning in ComponentState) then exit;

  //クライアント領域でのマウス位置を取得
  APos := ScreenToClient(Point(msg.XPos, msg.YPos));

  PosFlag := $00;
  //左端から5ドット未満
  if (APos.X < 5) then PosFlag := PosFlag or mptLeft;
  //上端から5ドット未満
  if (APos.Y < 5) then PosFlag := PosFlag or mptTop;
  //右端から5ドット未満
  if (ClientWidth - APos.X) < 5 then PosFlag := PosFlag or mptRight;
  //下端から5ドット未満
  if (ClientHeight - APos.Y) < 5 then PosFlag := PosFlag or mptBottom;

  case PosFlag of
    mptLeft            : msg.Result := HTLEFT;
    mptTop             : msg.Result := HTTOP;
    mptTop+mptLeft     : msg.Result := HTTOPLEFT;
    mptRight           : msg.Result := HTRIGHT;
    mptTop+mptRight    : msg.Result := HTTOPRIGHT;
    mptBottom          : msg.Result := HTBOTTOM;
    mptBottom+mptLeft  : msg.Result := HTBOTTOMLEFT;
    mptBottom+mptRight : msg.Result := HTBOTTOMRIGHT;
  else
    msg.Result := HTCAPTION;
  end;
end;

//=============================================================================
//  WM_NCHITTESTメッセージの処理でコントロールのクライアント領域にマウスカーソ
//  ルがある時にキャプションバー(HTCAPTION)としてしまったので、それに対する処置
//  この処理がないとダブルクリックでAlign:=alClient;としたのと同じとなる
//=============================================================================
procedure TplPicturePanel.WmSysCommand(var msg: TWmSysCommand);
begin
  //CmdTypeにSC_MAXIMIZE(最大化要求)が含まれている時は何もしない
  if (msg.CmdType or SC_MAXIMIZE) = msg.CmdType then begin
  end else begin
    //通常通り
    inherited;
  end;
end;

//=============================================================================
//  WM_ERASEBKGNDメッセージ処理
//  何も描画しない
//  このコンポでは、描画は全てPaintメソッドで実行している
//=============================================================================
procedure TplPicturePanel.WMEraseBkgnd(var Message: TWMEraseBkgnd);
begin
//
end;

end.



08_コントロールの移動リサイズ用コンポーネント


コンポーネントの紹介です。
ネット上で探すと、コントロールの移動リサイズ用のコンポーネントを見つけることができます。その 1 つです。[TSizeCtrl - Version 7.2]というコンポーネントをテストしてみました。
以下のサイトにあります。SizeControl.pas をコンポーネントとして登録します。コンポーネントのアイコンリソースは SizeControl.res です。


図9
TSizeCtrl コンポーネント
図10
添付のデモプログラム
  • プロジェクトをコンパイルして実行
  • 実行は Windows 7 U64 + Delphi XE

このコンポーネントは、
  • TSizeCtrl をフォームに配置
  • RegisterControl メソッドで移動リサイズするコントロールを指定
  • UnRegisterControl メソッドで移動リサイズ対象からコントロールを除外できる
  • Enabled プロパティを False にすると、全てのコントロールが対象から除外される
のように使用します。TControl の派生コントロール全てを操作できます。
以下はこのコンポーネントの簡単な使用例です。


図11
設計時画面
図12
実行画面
  • マウスの左ボタンを押下すると、グラブハンドルが表示される
  • [Shift] で複数のオブジェクトほを選択しての移動も可能
図13
複数のコントロールの移動

リスト14
TSizeCtrl コンポーネントの簡単な使用例 
unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    SizeCtrl1: TSizeCtrl;
    Panel1: TPanel;
    Button1: TButton;
    CheckBox1: TCheckBox;
    Image1: TImage;
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure Button1Click(Sender: TObject);
    procedure CheckBox1Click(Sender: TObject);
  private
    { Private 宣言 }
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

//=============================================================================
//  フォーム生成時の処理
//=============================================================================
procedure TForm1.FormCreate(Sender: TObject);
begin
  Self.Caption := 'TSizeCtrl コンポの簡単な使用方法';
  Self.DoubleBuffered := True;
  CheckBox1.Checked := True;

  //TSizeCtrlの対象コントロールの設定
  SizeCtrl1.RegisterControl(Panel1);
  SizeCtrl1.RegisterControl(Button1);

  Image1.Stretch := True;
  Image1.Transparent := False;
  SizeCtrl1.RegisterControl(Image1);
end;

//=============================================================================
//  フォーム破棄の時の処理
//=============================================================================
procedure TForm1.FormDestroy(Sender: TObject);
begin
  //TSizeCtrlの対象コントロールから外す
  SizeCtrl1.UnRegisterControl(Panel1);
  SizeCtrl1.UnRegisterControl(Button1);
  SizeCtrl1.UnRegisterControl(Image1);

  SizeCtrl1.Enabled := False;
end;

//=============================================================================
//  CheckBox1のOnClickイベント処理
//  SizeCtrl1のEnableプロパティの切換え
//=============================================================================
procedure TForm1.CheckBox1Click(Sender: TObject);
begin
  SizeCtrl1.Enabled := CheckBox1.Checked;
end;

//=============================================================================
//  SizeCtrl1のEnableプロパティがFalseの時は動作しない
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
begin
  ShowMessage('Button1 Clicked !');
end;

end.


下のリストは、このコンポーネントのデモプログラムに記述されているコードです。あるコントロールの子コントロール全てを対象にしたり、対象から除外することができます。 


//-----------------------------------------------------------------------------
//  引数のTWinControl上に配置した全てのコントロールを、TSizeCtrlの操作対象に
//  するためのプロシージャー(TSizeCtrlのRegisterControlメソッドの実行)
//  TSizeCtrlのEnabledプロパティをFalseにすると、自動的に除外処理をするらしい
//
//  再帰処理している
//-----------------------------------------------------------------------------
procedure RegComponents(aParent: TWinControl; SizeCtrl: TSizeCtrl);
var
  i: integer;
begin
  for i := 0 to aParent.ControlCount -1 do
  begin
    //In this demo, Tag <> 0 prevents a control becoming a SizeCtrl target ...
    if aParent.Controls[i].Tag = 0 then
      SizeCtrl.RegisterControl(aParent.Controls[i]);
    if aParent.Controls[i] is TWinControl then
      RegComponents(TWinControl(aParent.Controls[i]), SizeCtrl);
  end;
end;

//-----------------------------------------------------------------------------
//  引数のTWinControl上に配置した全てのコントロールを、TSizeCtrlの操作対象から
//  除外するプロシージャー(TSizeCtrlのUnRegisterControlメソッドの実行)
//  TSizeCtrlのEnabledプロパティをFalseにすると、自動的に除外処理をするらしい
//
//  再帰処理している
//-----------------------------------------------------------------------------
procedure UnregComponents(aParent: TWinControl; SizeCtrl: TSizeCtrl);
var
  i: integer;
begin
  for i := 0 to aParent.ControlCount -1 do
  begin
    SizeCtrl.UnRegisterControl(aParent.Controls[i]);
    if aParent.Controls[i] is TWinControl then
      UnregComponents(TWinControl(aParent.Controls[i]), SizeCtrl);
  end;
end;



09_実行時デザインシステム


これもコンポーネントの紹介です。
実行時デザインシステム (Runtime Design System) という名称のものです。以下の Torry's Delphi に登録されています。作者は、佐々木＠六角堂 さんです。

DsnUnit.pas をコンポーネントとして登録します。アイコンのリソースは DsnUnit.dcr です。

実行時にコントロールのプロパティ等を設定する趣旨で開発されたようです。下図のように、オブジェクト・インスペクタのようなプロパティ設定ダイアログも表示できるようになっています。



図14
コンポーネント群
図15
デモプログラムの実行例
  • [Sample1]フォルダのサンプルをコンパイルして実行
  • [DsnSwitch]をクリックするとデザインモードになる
  • コントロールをクリックすると、グラブハンドルが表示される

このコンポーネントの基本的な使用方法です。
  • TDsnStage を配置。この上に移動リサイズするコントロールを配置する
  • TDsn8Register を配置。DsnStageプロパティを TDsnStage にする
  • TDsnSwitch を配置。DsnRegister プロパティを TDsnRegister にする

TDsnSwitch ボタンをクリックすると、TDsnStage の上に配置しているコントロール類がデザインモードとなり、マウス操作で移動リサイズ可能となります。この操作はトグル動作となっています。その他のコンポーネント類はヘルプで確認してください。日本語のヘルプが添付されています。

以下はこのコンポーネントの簡単な使用例です。
TDsnSwitch を使用しなくても、次のように、TDsnRegister の Designing プロパティの値でもデザインモードの切換えができます。 



procedure TForm1.FormShow(Sender: TObject);
begin
  DsnRegister1.Designing := True;
end;


図16
設計時画面
  • 左上のボタンが TDsnSwitch コンポ
  • なくてもデザインモード切換は可能
図17
実行画面
  • [DsnSwitch1](左上のボタン)をクリックするとデザインモードになる
  • [Shift] で複数のコントロールを選択しの移動も可能 (動作は重たい)
図18
複数のコントロールを移動

リスト15
[実行時デザインシステム]コンポーネントの簡単な使用例 
unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, ExtCtrls, DsnUnit, Buttons, DsnSubMl, DsnSub8, DsnPanel, StdCtrls;

type
  TForm1 = class(TForm)
    DsnRegister1: TDsn8Register;
    DsnSwitch1: TDsnSwitch;
    DsnStage1: TDsnStage;
    Panel1: TPanel;
    Button1: TButton;
    procedure FormCreate(Sender: TObject);
  private
    { Private 宣言 }
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

//=============================================================================
//  フォーム生成時の処理
//
//  以下を配置して、オブジェクト・インスペクタで設定
//  DsnStage      : TDsnStage
//                  この上に移動リサイズするコントロールを配置する
//  Dsn8Register1 : TDsn8Register
//                  DsnStageプロパティをDsnStage1にする
//  DsnSwitch1    : TDsnSwitch
//                  DsnRegisterプロパティをDsnRegister1にする
//  実行時にDsnSwitch1をクリックすると、デザインモードになる
//  再度クリックすると、デザインモードが終了する
//  または、DsnRegister1.Designing := True; を実行する
//=============================================================================
procedure TForm1.FormCreate(Sender: TObject);
begin
  Self.Caption := '実行時デザインシステム 簡単な使用例';
end;

end.



10_How to Move and Resize Controls at Run Time


コンポーネントではありませんが、以下のリンクに、コントロールの実行移動リサイズのサンプルと解説のページがあります。3 ページあります。サンプルもダウンロードできます。
以下の図は、src110805 というファイルをダウンロードし、Windows 7 U64(SP1) + Delphi XE(UP1) でコンパイルして実行した結果です。


[備考]
2017年05月06日現在、上のリンクのページは記事の内容が変わっています。コードもダウンロードできません。



図19
設計時画面
図20
実行時画面
  • [Allow moving and resizing] をチェック
  • 任意のコントロールをクリック
  • グラブハンドルが表示され移動リサイズ可能となる

ダウンロードしたままのコードでは、グラブハンドルが上の図のようになっています。これを黒い色にするには、次のように、mover.pas 内の TMover.CreateNodes の部分に ParentBackground の値を設定します。 


procedure TMover.CreateNodes;
var
  Node: Integer;
  Panel: TPanel;
begin
  for Node := 0 to 7 do
  begin
    Panel := TPanel.Create(self);
    with Panel do
    begin
      ParentBackground := False;   //追加
      BevelOuter := bvNone;
      Color := clBlack;
      Name := 'Node' + IntToStr(Node);
      Width := 5;
      Height := 5;
      Parent := nil;
      Visible := false;
      FNodes.Add(Panel);
      case Node of
        0,4: Cursor := crSizeNWSE;
        1,5: Cursor := crSizeNS;
        2,6: Cursor := crSizeNESW;
        3,7: Cursor := crSizeWE;
      end;
      OnMouseDown := NodeMouseDown;
      OnMouseMove := NodeMouseMove;
      OnMouseUp := NodeMouseUp;
    end;
  end;
end;


図21
コードを修正した結果
  • グラブハンドルが黒い色となる