Delphi Programming / Object Pascal
サイトのトップページへ リンクのページへ ロゴマーク
[掲載 2012年07月23日] [更新 2013年12月20日]　Delphi サンプルプログラム集
154_画像の矩形範囲選択とラバーバンド
動作確認等 Windows XP(SP3) + Delphi XE Pro
Windows 7 U64(SP1) + Delphi XE Pro
154_Rubberband.zip　[5,207 KB]　2013年12月20日版 (EXE 同梱)






画像の矩形範囲選択とラバーバンド


画像のある矩形範囲を取り出したいとします。矩形というのは四角形のことです。つまり長方形です。長方形の位置とサイズは、数学的に 2 点の座標で決まります。
これをマウス操作で決定するには、画面上のある点をクリックした時、その座標値を記録しておきます。次にマウスをクリックしたら、その座標値も記録しておきます。これで矩形領域が決まることになります。
矩形領域が決まれば、TCanvas のメソッド類や Windows API を使用して、画像の、その部分だけを取り出すことができます。

実際の、多くのアプリケーションでは、最初の座標値から、マウスの移動に伴って、点線等で矩形領域を描画するようになっています。そうすることにより、今現在、どの範囲を選択中なのかを知ることができます。この点線等のことを「ラバーバンド」と言っているようです。

ラバーバンドを直訳すれば「ゴムひも」あるいは「輪ゴム」になります。
筆者は、この「ラバーバンド」の正解な意味は知りません。マウスなどのポインティングデバイスの動きに従って、リアルタイムに伸び縮みして描画される図形、という意味で、グラフィックスの世界では一般的に使用されているようです。当然、直線や矩形以外のラバーバンド描画もあります。

このページのサンプルは、矩形、つまり四角形のラバーバンドを描画し、表示画像の、ラバーバンドで囲まれた範囲だけを取り出す際の参考コードです。
ラバーバンドの終了点がドラッグ開始位置よりも左または上になってしまうと、矩形の幅と高さの値が負の値になってしまうサンプルがあります。画像の場合は、上下左右が反転してしまいます。利用の際に修正してください。




01_基本的なコード


当サイトの記事は難解だという指摘があります。おそらく、サンプルコードが長いのも「難解」と思う一因かも知れません。
そこで、最初のサンプルは、コードを短くするために、新規プロジェクトを作成し、そのフォームにラバーバンドを描画します。矩形ですから、矩形のサイズと位置を決定する 2 つの座標値が必要です。
  • (1) OnMouseDown イベントでマウスの左ボタン押下を検出
    その時の座標を一方の座標値とする
  • (2) OnMouseMove イベントで、現在のマウスの位置を検出
    これを、もう一方の座標値とする。この値はマウスカーソルの移動によって変化する
  • (3) OnMouseUp イベントで、範囲の選択を終了する
という手順になります。最低限、2 つの座標値と、範囲選択中かを判定するためのグローバル変数が必要となります。これ以降のサンプルでは、この範囲選択動作の判定用フラグに、論理型の変数を使用しています。
ラバーバンドは、マウスの移動で、前のラバーバンド、つまり矩形を重ね描画して消去し、新しい位置に矩形を描画することになります。そのために、Canvas の TPenMode の値を pmXOR 等に設定します。

このようなラバーバンドには、[370_スクリーンキャプチャ(アプリケーション)] のように、マウス移動だけでラバーバンドを描画していき、再度マウスクリックすると範囲選択の決定、という仕様のものがあります。また、[コントロール移動リサイズ] コンポーネントのように、グラブハンドルを持つものもあります。


図1
設計時画面
  • 何もない
図2
実行してラバーバンド描画
  • マウスの左ボタンを押したままでマウスをドラックした状態の図
図3
ラバーバンド描画終了
  • マウスのボタンを離すと終了
  • ラバーバンドで描いた矩形と同じ位置とサイズの四角形を描画

リスト1
ラバーバンド描画の基本テスト 
unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    procedure FormMouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure FormMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
    procedure FormMouseUp(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
  private
    InitX    : Integer;
    InitY    : Integer;
    PrevX    : Integer;
    PrevY    : Integer;
    DragFlag : Boolean;
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

//=============================================================================
//  このフォームのOnMouseDownイベント
//  ラバーバンドの描画開始
//
//  以下の値は、対象の背景、コーディング等の状況に応じて変更する
//  Canvas.Pen.Mode    := pmNotXor;
//  Canvas.Pen.Color   := clBlack;
//=============================================================================
procedure TForm1.FormMouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  if Button = mbLeft then begin
    //Canvasの描画をクリア
    Canvas.Brush.Style := bsSolid;
    Canvas.Brush.Color := Self.Color;
    Canvas.FillRect(ClientRect);

    //初期座標値
    InitX := X;
    InitY := Y;
    PrevX := X;
    PrevY := Y;
    DragFlag := True;

    //描画に使用するペンを設定
    Canvas.Pen.Mode    := pmNotXor;
    Canvas.Pen.Color   := clBlack;
    Canvas.Pen.Width   := 1;
    Canvas.Pen.Style   := psDot;
    Canvas.Brush.Style := bsClear;

    //矩形を描画
    Canvas.Rectangle(InitX, InitY, PrevX, PrevY);
  end;
end;

//=============================================================================
//  このフォームのOnMouseMoveイベント
//  マウスのドラッグにしたがって、ラバーバンドのサイズを変更
//=============================================================================
procedure TForm1.FormMouseMove(Sender: TObject; Shift: TShiftState; X,
  Y: Integer);
begin
  if not DragFlag then exit;

  //前の矩形の上に重ね描画して消去
  //そのために、Pen.Modeの値をpmXor,pmNotXor等にする
  //場合によってはpmNotも使用可能
  Canvas.Rectangle(InitX, InitY, PrevX, PrevY);
  //新しい座標値で矩形を描画
  Canvas.Rectangle(InitX, InitY, X, Y);

  //現在の値を保持
  PrevX := X;
  PrevY := Y;
end;

//=============================================================================
//  このフォームのOnMouseUpイベント
//  ラバーバンドの描画終了
//=============================================================================
procedure TForm1.FormMouseUp(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  if not DragFlag then exit;

  //ラバーバンドの描画終了
  DragFlag := false;

  //前の矩形の上に重ね描画して消去
  Canvas.Rectangle(InitX, InitY, PrevX, PrevY);

  //ラバーバンドの最終サイズで四角形を描画
  Canvas.Pen.Color := clBlue;
  Canvas.Pen.Width := 5;
  Canvas.Rectangle(InitX, InitY, PrevX, PrevY);
end;

end.



02_ラバーバンドを OnPaint イベントで描画


上のサンプルでは、マウスの移動に伴い、前に描画したラバーバンドを描画を消去し、新しい位置にラバーバンドを描画し直しています。そのために、描画のモードを pmNotXor としています。
次のコードのように、描画対象のコントロールの Canvas に OnPaint イベント内で描画すればこのような処理は必要ありません。
この後のサンプルのように、ラバーバンドも、ラバーバンドで決定した矩形領域に何かを描画する場合、TImage では永続的に描画がが行われます。TPaintBox や TPanel に描画する場合は永続的な描画は行われません。

一般的に、TImage は追加描画した内容も内部のビットマップが保持しています。描画内容を保持したままにしたい用途に適しています。一方、TPaintBox や TPanel の OnPaint イベントでの描画は、描画内容を頻繁に更新する必要がある用途に適していると言えます。OnPaint イベント内のコードは、再描画が必要になると自動的に実行されます。


リスト2
ラバーバンドを OnPaint イベントで描画 
unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    Button1: TButton;
    procedure FormMouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure FormMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
    procedure FormMouseUp(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure FormPaint(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure Button1Click(Sender: TObject);
  private
    InitX    : Integer;
    InitY    : Integer;
    PrevX    : Integer;
    PrevY    : Integer;
    DragFlag : Boolean;
    DrawShapeFlag : Boolean;
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

//=============================================================================
//  フォーム生成時の処理
//=============================================================================
procedure TForm1.FormCreate(Sender: TObject);
begin
  DragFlag      := False;
  DrawShapeFlag := False;
end;

//=============================================================================
//  ラバーバンドで指定した図形を描画しないようにする
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
begin
  DrawShapeFlag := False;
  //再描画
  Invalidate;
end;

//=============================================================================
//  このフォームのOnMouseDownイベント
//  ラバーバンドの描画開始
//=============================================================================
procedure TForm1.FormMouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  if Button = mbLeft then begin
    //初期座標値
    InitX := X;
    InitY := Y;
    PrevX := X;
    PrevY := Y;
    DragFlag      := True;
    DrawShapeFlag := False;
    //再描画
    Invalidate;
  end;
end;

//=============================================================================
//  このフォームのOnMouseMoveイベント
//  マウスのドラッグにしたがって、ラバーバンドのサイズを変更
//=============================================================================
procedure TForm1.FormMouseMove(Sender: TObject; Shift: TShiftState; X,
  Y: Integer);
begin
  if DragFlag then begin
    //現在の値を保持
    PrevX := X;
    PrevY := Y;
    //再描画
    Invalidate;
  end;
end;

//=============================================================================
//  このフォームのOnMouseUpイベント
//  ラバーバンドの描画終了
//=============================================================================
procedure TForm1.FormMouseUp(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  if DragFlag then begin
    //ラバーバンドの描画終了
    DragFlag      := false;
    DrawShapeFlag := True;
    //再描画
    Invalidate;
  end;
end;

//=============================================================================
//  このフォームのOnPaintイベント
//  ラバーバンドの描画
//=============================================================================
procedure TForm1.FormPaint(Sender: TObject);
begin
  if DragFlag then begin
    //描画に使用するペンを設定
    Canvas.Pen.Mode    := pmNotXor;
    Canvas.Pen.Color   := clBlack;
    Canvas.Pen.Width   := 1;
    Canvas.Pen.Style   := psDot;
    Canvas.Brush.Style := bsClear;
    //描画
    Canvas.Rectangle(InitX, InitY, PrevX, PrevY);
  end;

  if DrawShapeFlag then begin
    //ラバーバンドの最終サイズで四角形を描画
    Canvas.Pen.Color := clBlue;
    Canvas.Pen.Width := 5;
    Canvas.Rectangle(InitX, InitY, PrevX, PrevY);
  end;
end;

end.



03_クリックした 2 点で矩形範囲を決定


マウスのドラッグではなく、最初にクリックした点と、次にクリックした点の 2 点で決まる矩形領域を取得する場合は、上のサンプルの OnMouseDown イベントを使用しないで、OnMouseUp イベントのコードを、例えば次のようにします。
OnClick イベントでもできますが、OnClick イベントを使用する場合は、GetCursorPos 関数、あるいは OnMouseMove イベント内でマウスカーソル位置を取得して、それを使用することになります。


リスト3
クリックした 2 点で矩形範囲を決定 
procedure TForm1.FormMouseUp(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  if Button = mbLeft then begin
    if not DragFlag then begin
      DragFlag      := True;
      DrawShapeFlag := False;

      //初期座標値
      InitX := X;
      InitY := Y;
      PrevX := X;
      PrevY := Y;
    end else begin
      //ラバーバンドの描画終了
      DragFlag      := false;
      DrawShapeFlag := True;
      //再描画
    end;
    Invalidate;
  end;
end;



04_TImage の Canvas にラバーバンドを描画


上のサンプルのように、フォームに描画した図形は、他のウインドウが重なると、再描画のため、消えてしまいます。これは、TPaintBox への描画と同じ現象です。
次のサンプルでは、TImage の Canvas 上にラバーバンドを描画します。こちらの方がより一般的でしょう。


図4
設計時画面
  • TImage を配置
図5
実行してラバーバンド描画
  • マウスの左ボタンを押したままでマウスをドラックした状態の図
図6
ラバーバンド描画終了
  • マウスのボタンを離すと終了
  • ラバーバンドで描いた矩形と同じ位置とサイズの四角形を描画

リスト4
TImage の Canvas にラバーバンドを描画 
unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    Image1: TImage;
    procedure FormCreate(Sender: TObject);
    procedure Image1MouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure Image1MouseMove(Sender: TObject; Shift: TShiftState; X,
      Y: Integer);
    procedure Image1MouseUp(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
  private
    { Private 宣言 }
    InitX    : Integer;
    InitY    : Integer;
    PrevX    : Integer;
    PrevY    : Integer;
    DragFlag : Boolean;
    ImgBackColor : TColor;
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

//=============================================================================
//  フォーム作成時の処理
//=============================================================================
procedure TForm1.FormCreate(Sender: TObject);
begin
  //Imgae1を塗り潰す
  ImgBackColor := clSkyBlue;
  Image1.Canvas.Brush.Color := ImgBackColor;
  Image1.Canvas.Brush.Style := bsSolid;
  Image1.Canvas.FillRect(Image1.ClientRect);
end;

//=============================================================================
//  Image1のOnMouseDownイベント
//  ラバーバンドの描画開始
//
//  以下の値は、対象の背景、コーディング等の状況に応じて変更する
//  Canvas.Pen.Mode    := pmNotXor;
//  Canvas.Pen.Color   := clBlack;
//=============================================================================
procedure TForm1.Image1MouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  if Button = mbLeft then begin
    //Canvasの描画をクリア
    Image1.Canvas.Brush.Color := ImgBackColor;
    Image1.Canvas.Brush.Style := bsSolid;
    Image1.Canvas.FillRect(Image1.ClientRect);

    //初期座標値
    InitX := X;
    InitY := Y;
    PrevX := X;
    PrevY := Y;
    DragFlag := True;

    //描画に使用するペンを設定
    Image1.Canvas.Pen.Mode    := pmNotXor;
    Image1.Canvas.Pen.Color   := clBlack;
    Image1.Canvas.Pen.Width   := 1;
    Image1.Canvas.Pen.Style   := psDot;
    Image1.Canvas.Brush.Style := bsClear;

    //矩形を描画
    Image1.Canvas.Rectangle(InitX, InitY, PrevX, PrevY);
  end;
end;

//=============================================================================
//  Image1のOnMouseMoveイベント
//  マウスのドラッグにしたがって、ラバーバンドのサイズを変更
//=============================================================================
procedure TForm1.Image1MouseMove(Sender: TObject; Shift: TShiftState; X,
  Y: Integer);
begin
  if not DragFlag then exit;

  //前の矩形の上に重ね描画して消去
  //そのために、Pen.Modeの値をpmXor,pmNotXor等にする
  //場合によってはpmNotも使用可能
  Image1.Canvas.Rectangle(InitX, InitY, PrevX, PrevY);
  //新しい座標値で矩形を描画
  Image1.Canvas.Rectangle(InitX, InitY, X, Y);

  //現在の値を保持
  PrevX := X;
  PrevY := Y;
end;

//=============================================================================
//  Image1のOnMouseUpイベント
//  ラバーバンドの描画終了
//=============================================================================
procedure TForm1.Image1MouseUp(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  if not DragFlag then exit;

  //ラバーバンドの描画終了
  DragFlag := false;

  //前の矩形の上に重ね描画して消去
  Image1.Canvas.Rectangle(InitX, InitY, PrevX, PrevY);

  //ラバーバンドの最終サイズで四角形を描画
  Image1.Canvas.Pen.Mode  := pmCopy;
  Image1.Canvas.Pen.Color := clBlue;
  Image1.Canvas.Pen.Width := 5;
  Image1.Canvas.Rectangle(InitX, InitY, PrevX, PrevY);
end;

end.



05_ビットマップ画像の矩形選択範囲をビットマップ出力


ここからが本題です。
あらかじめ TImage にビットマップ画像を表示しておき、表示している画像の、ラバーバンドで選択した矩形範囲だけを取り出して、他の TImage に表示します。
大きな画像もスクロールして表示できるように、スクロールボックスを配置し、その上に TImage を配置しています。ラバーバンドの移動に伴い自動的にスクロールするようにしてみました。また、ラバーバンドが、TImage の外側には描画できないようするための制御コードも追加しています。

このサンプルのコードは、TImage の Canvas に描画、表示している画像であれば、どんな画像でも同様に扱えます。ただし、出力はビットマップとなります。


図7
設計時画面
  • 画像は、あらかじめ読み込んである
  • 下の TImage は、範囲指定した画像の表示用
図8
実行してラバーバンドを描画
図9
画像の指定範囲だけを表示

リスト5
ビットマップ画像の矩形選択範囲をビットマップ出力 
unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    ScrollBox1: TScrollBox;
    Splitter1: TSplitter;
    ScrollBox2: TScrollBox;
    Image1: TImage;
    Image2: TImage;
    procedure FormCreate(Sender: TObject);
    procedure Image1MouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure Image1MouseMove(Sender: TObject; Shift: TShiftState; X,
      Y: Integer);
    procedure Image1MouseUp(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure FormMouseWheel(Sender: TObject; Shift: TShiftState;
      WheelDelta: Integer; MousePos: TPoint; var Handled: Boolean);
  private
    { Private 宣言 }
    InitX      : Integer;
    InitY      : Integer;
    PrevX      : Integer;
    PrevY      : Integer;
    DragFlag   : Boolean;
    Image1Top  : Integer;
    Image1Left : Integer;
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

//=============================================================================
//  フォーム作成時の処理
//  Image1, Image2共にAutoSizeはTrueにしてある
//=============================================================================
procedure TForm1.FormCreate(Sender: TObject);
begin
  Image1.Left := 0;
  Image1.Top  := 0;

  Image2.Left := 0;
  Image2.Top  := 0;

  Image1Top  := Image1.Top;
  Image1Left := Image1.Left;

  //スクロールバーのドラッグで同時にスクロールさせる
  ScrollBox1.HorzScrollBar.Tracking := True;
  ScrollBox1.VertScrollBar.Tracking := True;
  ScrollBox2.HorzScrollBar.Tracking := True;
  ScrollBox2.VertScrollBar.Tracking := True;
end;

//=============================================================================
//  Image1のフォームのOnMouseDownイベント
//  ラバーバンドの描画開始
//
//  以下の値は、対象の背景、コーディング等の状況に応じて変更する
//  Canvas.Pen.Mode    := pmNotXor;
//  Canvas.Pen.Color   := clBlack;
//=============================================================================
procedure TForm1.Image1MouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  if Button = mbLeft then begin
    //初期座標値
    InitX := X;
    InitY := Y;
    PrevX := X;
    PrevY := Y;
    DragFlag := True;

    //描画に使用するペンを設定
    Image1.Canvas.Pen.Mode    := pmNotXor;
    Image1.Canvas.Pen.Color   := clBlack;
    Image1.Canvas.Pen.Width   := 1;
    Image1.Canvas.Pen.Style   := psDot;
    Image1.Canvas.Brush.Style := bsClear;

    //矩形を描画
    Image1.Canvas.Rectangle(InitX, InitY, PrevX, PrevY);
  end;
end;

//=============================================================================
//  Image1のOnMouseMoveイベント
//  マウスのドラッグにしたがって、ラバーバンドのサイズを変更
//=============================================================================
procedure TForm1.Image1MouseMove(Sender: TObject; Shift: TShiftState; X,
  Y: Integer);
var
  PosYInClient : Integer;
  PosXInClient : Integer;
  APoint       : TPoint;
  StopCursorX  : Integer;
  StopCursorY  : Integer;
begin
  if not DragFlag then exit;

  Image1.Canvas.Rectangle(InitX, InitY, PrevX, PrevY);
  Image1.Canvas.Rectangle(InitX, InitY, X, Y);

  //現在の値を退避
  PrevX := X;
  PrevY := Y;


  //マウスカーソルの移動制限
  if (X < 0)                   or
     (Y < 0)                   or
     (X > Image1.ClientWidth)  or
     (Y > Image1.ClientHeight) then begin

    StopCursorX := X;
    StopCursorY := Y;

    if X < 0                   then StopCursorX := 0;
    if Y < 0                   then StopCursorY := 0;
    if X > Image1.ClientWidth  then StopCursorX := Image1.ClientWidth;
    if Y > Image1.ClientHeight then StopCursorY := Image1.ClientHeight;

    APoint := Image1.ClientToScreen(Point(StopCursorX, StopCursorY));
    SetCursorPos(APoint.X, APoint.Y);
    exit;
  end;

  //以下、スクロール制御関係
  //動作仕様は、好みに応じて変更する

  PosYInClient := PrevY - ScrollBox1.VertScrollBar.Position + Image1Top;
  PosXInClient := PrevX - ScrollBox1.HorzScrollBar.Position + Image1Left;

  //縦方向のスクロール移動制御
  //下方向スクロール
  if PosYInClient >= ScrollBox1.ClientHeight then begin
    ScrollBox1.VertScrollBar.Position := PrevY - ScrollBox1.ClientHeight + Image1Top;
  end else
  //上方向スクロール
  if PosYInClient < 0 then begin
    ScrollBox1.VertScrollBar.Position := PrevY + Image1Top - 5;
  end;

  //横方向のスクロール移動制御
  //右方向スクロール
  if PosXInClient >= ScrollBox1.ClientWidth then begin
    ScrollBox1.HorzScrollBar.Position := PrevX - ScrollBox1.ClientWidth + Image1Left;
  end else
  //左方向スクロール
  if PosXInClient < 0 then begin
    ScrollBox1.HorzScrollBar.Position := PrevX + Image1Left - 5;
  end;
end;

//=============================================================================
//  Image1のOnMouseUpイベント
//  ラバーバンドの描画終了
//=============================================================================
procedure TForm1.Image1MouseUp(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
var
  Bmp        : TBitmap;
  SourceRect : TRect;
  DestRect   : TRect;
begin
  if not DragFlag then exit;

  //ラバーバンドの描画終了
  DragFlag := false;

  //前の矩形の上に重ね描画して消去
  Image1.Canvas.Rectangle(InitX, InitY, PrevX, PrevY);

  //転送元と転送先の領域を指定
  SourceRect := Rect(InitX, InitY, PrevX, PrevY);
  DestRect   := Rect(0, 0, Abs(PrevX - InitX), Abs(PrevY - InitY));

  //ビットマップに転送元の領域を描画して、それをImage2に描画
  Bmp := TBitmap.Create;
  try
    Bmp.Width  := Abs(PrevX - InitX);
    Bmp.Height := Abs(PrevY - InitY);
    Bmp.Canvas.CopyRect(DestRect, Image1.Canvas, SourceRect);

    Image2.AutoSize := True;
    Image2.Picture.Bitmap.Assign(Bmp);
  finally
    FreeAndNil(Bmp);
  end;
end;

//=============================================================================
//  Form1のOnMouseWheelイベント
//  スクロールボックスをマウスホイールでスクロールさせる
//=============================================================================
procedure TForm1.FormMouseWheel(Sender: TObject; Shift: TShiftState;
  WheelDelta: Integer; MousePos: TPoint; var Handled: Boolean);
var
  SB1 : TScrollBox;
  SB2 : TScrollBox;
begin
  SB1 := ScrollBox1;
  SB2 := ScrollBox2;

  if FindVCLWindow(MousePos) = SB1 then begin
    Handled := True;
    SB1.VertScrollBar.Position := SB1.VertScrollBar.Position - WheelDelta div 5;
  end;
  if FindVCLWindow(MousePos) = SB2 then begin
    Handled := True;
    SB2.VertScrollBar.Position := SB2.VertScrollBar.Position - WheelDelta div 5;
  end;
end;

end.


上のサンプルで使用しているスクロールイベントは、マウスカーソル下のコントロールをスクロールさせるためのものです。このイベントのコードを使用すると、対象のコントロールにフォーカスがなくてもスクロールすることができます。 


procedure TForm1.FormMouseWheel(Sender: TObject; Shift: TShiftState;
  WheelDelta: Integer; MousePos: TPoint; var Handled: Boolean);
var
  SB1 : TScrollBox;
  SB2 : TScrollBox;
begin
  SB1 := ScrollBox1;
  SB2 := ScrollBox2;

  if FindVCLWindow(MousePos) = SB1 then begin
    Handled := True;
    SB1.VertScrollBar.Position := SB1.VertScrollBar.Position - WheelDelta div 5;
  end;
  if FindVCLWindow(MousePos) = SB2 then begin
    Handled := True;
    SB2.VertScrollBar.Position := SB2.VertScrollBar.Position - WheelDelta div 5;
  end;
end;


TScrollBox 以外の TMemo, TRichEdit 等のスクロールであれば、以下のように、メッセージで処理することもできます。 


procedure TForm1.FormMouseWheel(Sender: TObject; Shift: TShiftState;
  WheelDelta: Integer; MousePos: TPoint; var Handled: Boolean);
var
   AControl : TWinControl;
begin
  AControl := FindVCLWindow(MousePos);

  if (AControl is TScrollBox) or (AControl is TMemo) then begin
    if WheelDelta > 0 then begin
      AControl.Perform(WM_VSCROLL, SB_LINEUP, 0);
    end else begin
      AControl.Perform(WM_VSCROLL, SB_LINEDOWN, 0);
    end;
  end;
  Handled := true;
end;



06_メタファイル画像の矩形選択範囲をビットマップ出力


上のサンプルの説明で、TImage の Canvas に描画、表示している画像であれば、どんな画像でも同様に扱えますと書きました。実際にメタファイル画像でテストするのがこのサンプルです。
Timage は内部にメタファイルを保持していますが、TImage の Canvas に描画されているのは、ビットマップです。このビットマップ画像に対して操作することになります。

起動時に、PlayEnhMetaFile 関数で Timage の Canvas にメタファイルを描画していますが、本サンプルではこの関数を使用する必然性は特にありません。StretchDraw 関数で十分です。
大きなサイズや大量のメタファイルを表示する場合、PlayEnhMetaFile 関数を使用しないと、画像が欠損することがあります。


図10
摂家時画面
  • 画像は実行時にディクスから読み込む
図11
実行してラバーバンドを描画
図12
画像の指定範囲だけを表示

リスト6
メタファイル画像の矩形選択範囲をビットマップ出力 
unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    ScrollBox1: TScrollBox;
    Splitter1: TSplitter;
    ScrollBox2: TScrollBox;
    Image1: TImage;
    Image2: TImage;
    procedure FormCreate(Sender: TObject);
    procedure Image1MouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure Image1MouseMove(Sender: TObject; Shift: TShiftState; X,
      Y: Integer);
    procedure Image1MouseUp(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure FormMouseWheel(Sender: TObject; Shift: TShiftState;
      WheelDelta: Integer; MousePos: TPoint; var Handled: Boolean);
  private
    { Private 宣言 }
    InitX      : Integer;
    InitY      : Integer;
    PrevX      : Integer;
    PrevY      : Integer;
    DragFlag   : Boolean;
    Image1Top  : Integer;
    Image1Left : Integer;
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

//=============================================================================
//  フォーム作成時の処理
//  Image1のAutoSizeはFalseにしてある
//=============================================================================
procedure TForm1.FormCreate(Sender: TObject);
var
  APict : TPicture;
begin
  Image1.Left := 0;
  Image1.Top  := 0;

  Image2.Left := 0;
  Image2.Top  := 0;

  Image1Top  := Image1.Top;
  Image1Left := Image1.Left;

  Image1.Picture := nil;
  APict := TPicture.Create;
  try
    APict.LoadFromFile(ExtractFilePath(Application.ExeName) + 'bird.wmf');
    Image1.Width  := 500;
    Image1.Height := Image1.Width * Round(APict.Height / APict.Width);
    PlayEnhMetaFile(Image1.Canvas.Handle, APict.Metafile.Handle, Image1.ClientRect);
  finally
    FreeAndNil(APict);
  end;


  //スクロールバーのドラッグで同時にスクロールさせる
  ScrollBox1.HorzScrollBar.Tracking := True;
  ScrollBox1.VertScrollBar.Tracking := True;
  ScrollBox2.HorzScrollBar.Tracking := True;
  ScrollBox2.VertScrollBar.Tracking := True;
end;


//=============================================================================
//  Image1のOnMouseDownイベント
//  ラバーバンドの描画開始
//
//  以下の値は、対象の背景、コーディング等の状況に応じて変更する
//  Canvas.Pen.Mode    := pmNotXor;
//  Canvas.Pen.Color   := clBlack;
//=============================================================================
procedure TForm1.Image1MouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  if Button = mbLeft then begin
    //初期座標値
    InitX := X;
    InitY := Y;
    PrevX := X;
    PrevY := Y;
    DragFlag := True;

    //描画に使用するペンを設定
    Image1.Canvas.Pen.Mode    := pmNotXor;
    Image1.Canvas.Pen.Color   := clBlack;
    Image1.Canvas.Pen.Width   := 1;
    Image1.Canvas.Pen.Style   := psDot;
    Image1.Canvas.Brush.Style := bsClear;

    //矩形を描画
    Image1.Canvas.Rectangle(InitX, InitY, PrevX, PrevY);
  end;
end;

//=============================================================================
//  Image1のOnMouseMoveイベント
//  マウスのドラッグにしたがって、ラバーバンドのサイズを変更
//=============================================================================
procedure TForm1.Image1MouseMove(Sender: TObject; Shift: TShiftState; X,
  Y: Integer);
var
  PosYInClient : Integer;
  PosXInClient : Integer;
  APoint       : TPoint;
  StopCursorX  : Integer;
  StopCursorY  : Integer;
begin
  if not DragFlag then exit;

  Image1.Canvas.Rectangle(InitX, InitY, PrevX, PrevY);
  Image1.Canvas.Rectangle(InitX, InitY, X, Y);

  //現在の値を退避
  PrevX := X;
  PrevY := Y;

  //マウスカーソルの移動制限
  if (X < 0)                   or
     (Y < 0)                   or
     (X > Image1.ClientWidth)  or
     (Y > Image1.ClientHeight) then begin

    StopCursorX := X;
    StopCursorY := Y;

    if X < 0                   then StopCursorX := 0;
    if Y < 0                   then StopCursorY := 0;
    if X > Image1.ClientWidth  then StopCursorX := Image1.ClientWidth;
    if Y > Image1.ClientHeight then StopCursorY := Image1.ClientHeight;

    APoint := Image1.ClientToScreen(Point(StopCursorX, StopCursorY));
    SetCursorPos(APoint.X, APoint.Y);
    exit;
  end;

  //以下、スクロール制御関係
  //動作仕様は、好みに応じて変更する

  PosYInClient := PrevY - ScrollBox1.VertScrollBar.Position + Image1Top;
  PosXInClient := PrevX - ScrollBox1.HorzScrollBar.Position + Image1Left;

  //縦方向のスクロール移動制御
  //下方向スクロール
  if PosYInClient >= ScrollBox1.ClientHeight then begin
    ScrollBox1.VertScrollBar.Position := PrevY - ScrollBox1.ClientHeight + Image1Top;
  end else
  //上方向スクロール
  if PosYInClient < 0 then begin
    ScrollBox1.VertScrollBar.Position := PrevY + Image1Top - 5;
  end;

  //横方向のスクロール移動制御
  //右方向スクロール
  if PosXInClient >= ScrollBox1.ClientWidth then begin
    ScrollBox1.HorzScrollBar.Position := PrevX - ScrollBox1.ClientWidth + Image1Left;
  end else
  //左方向スクロール
  if PosXInClient < 0 then begin
    ScrollBox1.HorzScrollBar.Position := PrevX + Image1Left - 5;
  end;
end;

//=============================================================================
//  Image1のOnMouseUpイベント
//  ラバーバンドの描画終了
//  矩形範囲をビットマップとして、Imaage2に表示
//=============================================================================
procedure TForm1.Image1MouseUp(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
var
  Bmp        : TBitmap;
  SourceRect : TRect;
  DestRect   : TRect;
begin
  if not DragFlag then exit;

  //ラバーバンドの描画終了
  DragFlag := false;

  //前の矩形の上に重ね描画して消去
  Image1.Canvas.Rectangle(InitX, InitY, PrevX, PrevY);

  //転送元と転送先の領域を指定
  SourceRect := Rect(InitX, InitY, PrevX, PrevY);
  DestRect   := Rect(0, 0, Abs(PrevX - InitX), Abs(PrevY - InitY));

  //ビットマップに転送元の領域を描画して、それをImage2に描画
  Bmp := TBitmap.Create;
  try
    Bmp.Width  := Abs(PrevX - InitX);
    Bmp.Height := Abs(PrevY - InitY);
    Bmp.Canvas.CopyRect(DestRect, Image1.Canvas, SourceRect);

    Image2.AutoSize := True;
    Image2.Picture.Bitmap.Assign(Bmp);
    Bmp.SaveToFile(ExtractFilePath(Application.ExeName) + 'ABC.bmp');
  finally
    FreeAndNil(Bmp);
  end;
end;

//=============================================================================
//  Form1のOnMouseWheelイベント
//  スクロールボックスをマウスホイールでスクロールさせる
//=============================================================================
procedure TForm1.FormMouseWheel(Sender: TObject; Shift: TShiftState;
  WheelDelta: Integer; MousePos: TPoint; var Handled: Boolean);
var
  SB1 : TScrollBox;
  SB2 : TScrollBox;
begin
  SB1 := ScrollBox1;
  SB2 := ScrollBox2;

  if FindVCLWindow(MousePos) = SB1 then begin
    Handled := True;
    SB1.VertScrollBar.Position := SB1.VertScrollBar.Position - WheelDelta div 5;
  end;
  if FindVCLWindow(MousePos) = SB2 then begin
    Handled := True;
    SB2.VertScrollBar.Position := SB2.VertScrollBar.Position - WheelDelta div 5;
  end;
end;

end.



07_メタファイル画像の指定矩形範囲をメタファイル画像として出力


次は、TImage に描画されているメタファイル画像の一部、矩形領域 (四角形の領域) を、メタファイル画像として取り出すサンプルです。

この操作は少し面倒です。TImage の Canvas に表示したメタファイル画像、これは、実際にはメタファイルをビットマップに変換した画像が表示されています。この時、下のリストのように、メタファイルを操作、参照すると、参考リンクの記事にあるように、メタファイルが破棄されてしまいます。
これを避けるために、
  • Image1.Picture.MetaFile.Assign(MetaFile);
  • Image1.Picture.MetaFile.LoadFromFile('Test.emf');
のようなコードでメタファイルを表示すると、TImage の Bitmap の Canvas が生成されないため、これまでのサンプルのようなラバーバンドが描画できません。
そこで、このサンプルでは、メタファイル画像の取り出しだけをテストするために、ラバーバンドは使用しないで、代わりに TShape を表示し、その矩形範囲をメタファイルとして取得します。TShape のサイズは変更できませんが、ドラッグ操作で、位置は変更できるようにしています。


リスト7
Canvas に描画しないと、これまでのラバーバンドのコードは使用できないが、
メタファイルを Canvas に描画した場合、メタファイルを参照すると画像が消えてしまう 

procedure TForm1.Button1Click(Sender: TObject);
var
  MetaFile : TMetafile;
begin
  MetaFile := TMetafile.Create;
  try
    //対象のメタファイル画像をディスクから読み出して表示
    MetaFile.LoadFromFile('bird.wmf');

    //表示サイズの設定
    Image1.Width  := MetaFile.Width;
    Image1.Height := MetaFile.Height;
    Image1.Canvas.Draw(0, 0, MetaFile);

    //メタファイルを参照すると、Image1の画像が消えてしまう
    Image1.Picture.Metafile.SaveToFile('001.emf');
  finally
    FreeAndNil(MetaFile);
  end;
end;


テスト結果とコードです。メタファイルの取り出しにはマッピングという手法を使用しています。
  • (1) メタファイルを生成し、そこに Image1 のメタファイルを取り出して格納
  • (2) 取り出した指定範囲のメタファイルを格納するための、別のメタファイルを生成
  • (3) この指定範囲格納用のメタファイルの Canvas のビューサイズを設定
  • (4) サイズ設定だけでは左上からとなってしまうので、左端と上端からのオフセットを設定
  • (5) 指定範囲格納用のメタファイルの Canvas に、Image1 から取得したメタファイルを描画
  • (6) 指定範囲格納用のメタファイルを、Image2 に表示
という手順になります。この手法は、メタファイル以外の画像にも利用できます。サンプルでは、参考用に、取り出したメタファイルを保存し、クリップボードにコピーしています。


図13
設計時画面
  • 白いのは TShape
  • 範囲指定には、この TShape を使用
図14
実行開始画面
図15
ボタンをクリック
  • 取り出した画像もメタファイルなので「ギザギザ」はない
図16
別の部分を取り出した結果

下の図は、ほぼ同じ領域を、前のサンプルプログラムを使い、ビットマップで出力した画像です。直線部分が拡大されて「ギザギザ」になっています。メタファイルならこのようにはなりません。


図17
ビットマップで取り出した場合

リスト8
メタファイル画像の指定矩形範囲をメタファイル画像として出力 
unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    Panel1: TPanel;
    Splitter1: TSplitter;
    ScrollBox1: TScrollBox;
    Image1: TImage;
    ScrollBox2: TScrollBox;
    Image2: TImage;
    Button1: TButton;
    Shape1: TShape;
    procedure FormCreate(Sender: TObject);
    procedure FormMouseWheel(Sender: TObject; Shift: TShiftState;
      WheelDelta: Integer; MousePos: TPoint; var Handled: Boolean);
    procedure Button1Click(Sender: TObject);
    procedure Shape1MouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure Shape1DragOver(Sender, Source: TObject; X, Y: Integer;
      State: TDragState; var Accept: Boolean);
    procedure Shape1DragDrop(Sender, Source: TObject; X, Y: Integer);
  private
    { Private 宣言 }
    DragStartTop  : Integer;
    DragStartLeft : Integer;
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

uses Clipbrd;

{$R *.dfm}

//=============================================================================
//  フォーム作成時の処理
//=============================================================================
procedure TForm1.FormCreate(Sender: TObject);
var
  MetaFile : TMetafile;
begin
  Image1.Left := 0;
  Image1.Top  := 0;
  Image2.Left := 0;
  Image2.Top  := 0;

  MetaFile := TMetafile.Create;
  try
    //対象のメタファイル画像をディスクから読み出して表示
    MetaFile.LoadFromFile('bird.wmf');
    Image1.AutoSize := True;
    Image1.Picture.Assign(MetaFile);
  finally
    FreeAndNil(MetaFile);
  end;

  //取り出す矩形範囲をTShapeで表示
  Shape1.Brush.Style := bsClear;
  Shape1.Left   := 140;
  Shape1.Top    := 180;
  Shape1.Width  := 130;
  Shape1.Height := 70;


  //スクロールバーのドラッグで同時にスクロールさせる
  ScrollBox1.HorzScrollBar.Tracking := True;
  ScrollBox1.VertScrollBar.Tracking := True;
  ScrollBox2.HorzScrollBar.Tracking := True;
  ScrollBox2.VertScrollBar.Tracking := True;
end;

//=============================================================================
//  画像の指定矩形領域だけの部分画像を取り出す
//  マッピングという手法を使う
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
var
  AStream    : TMemoryStream;
  SourceMeta : TMetafile;
  DestMeta   : TMetafile;
  DestCanvas : TMetafileCanvas;
  CopyOrginX : Integer;
  CopyOrginY : Integer;
begin
   //Image2の画像をクリア
   Image2.Picture.Assign(nil);

   AStream    := TMemoryStream.Create;
   SourceMeta := TMetafile.Create;
   DestMeta   := TMetaFile.Create;
   try
     //Image1のメタファイルをメモリストリームに保存
     Image1.Picture.MetaFile.SaveToStream(AStream);
     //メモリストリームに保存した画像を読み出す
     AStream.Position := 0;
     SourceMeta.LoadFromStream(AStream);
   finally
     FreeAndNil(AStream);
   end;

   try
     //ここでサイズを設定しなければ、TMetaCanvas.CreateしてFreeすると
     //サイズが自動で決定される
     //DestMetaが加工用のメタファイルで、加工後にImage2に表示する
     DestMeta.Width  := SourceMeta.Width;
     DestMeta.Height := Round(DestMeta.Width * Shape1.Height / Shape1.Width);;

     //メタファイルの幅と高さ取得するために一度CreateしてFree
     DestCanvas := TMetaFileCanvas.Create(DestMeta, 0);
     FreeAndNil(DestCanvas);

     //TMetaFile.Createの後にサイズを設定しない場合は、この時点で自動決定される
     //TMetaFile.Createの後に設定しない場合の自動設定のサイズはスクリーンサイズ

     //改めてDestMetaCanvasをCreate
     DestCanvas := TMetaFileCanvas.Create(DestMeta, 0);
     try
       //切り出すサイズの設定(マッピング)
       SetMapMode      (DestCanvas.Handle, MM_ANISOTROPIC);
       SetWindowExtEx  (DestCanvas.Handle, Shape1.Width,   Shape1.Height,   nil);
       SetViewPortExtEx(DestCanvas.Handle, DestMeta.Width, DestMeta.Height, nil);

       //スクロール分の補正をして、切り出す部分の左端と上端の座標値を設定
       CopyOrginX := Shape1.Left + ScrollBox1.HorzScrollBar.Position;
       CopyOrginY := Shape1.Top  + ScrollBox1.VertScrollBar.Position;

       SetWindowOrgEx (DestCanvas.Handle, CopyOrginX, CopyOrginY, nil);

       //DestMetaCanvasにSourceMetaFileの図形を描画
       //この時、矩形範囲内の画像だけがDestMetaCanvasに描画される
       DestCanvas.Draw(0, 0, SourceMeta);
     finally
       //CanvasをFreeすれば描画終了
       FreeAndNil(DestCanvas);
     end;

     //確認のための保存
     DestMeta.SaveToFile('ABC.emf');
     //テスト用にクリップボードにコピー
     Clipboard.Assign(DestMeta);

     //切り出したメタファイルをImage2に描画
     Image2.AutoSize := True;
     Image2.Picture.Assign(DestMeta);
   finally
     //終了したらFreeしてnil
     FreeAndNil(SourceMeta);
     FreeAndNil(DestMeta);
   end;
end;

//=============================================================================
//  Form1のOnMouseWheelイベント
//  スクロールボックスをマウスホイールでスクロールさせる
//=============================================================================
procedure TForm1.FormMouseWheel(Sender: TObject; Shift: TShiftState;
  WheelDelta: Integer; MousePos: TPoint; var Handled: Boolean);
var
  SB1 : TScrollBox;
  SB2 : TScrollBox;
begin
  SB1 := ScrollBox1;
  SB2 := ScrollBox2;

  if FindVCLWindow(MousePos) = SB1 then begin
    Handled := True;
    SB1.VertScrollBar.Position := SB1.VertScrollBar.Position - WheelDelta div 5;
  end;
  if FindVCLWindow(MousePos) = SB2 then begin
    Handled := True;
    SB2.VertScrollBar.Position := SB2.VertScrollBar.Position - WheelDelta div 5;
  end;
end;

//=============================================================================
//  Shape1のOnMouseDownイベント
//  マウスをDownしたらドラッグ開始
//
//  ラバーバンドではなく、矩形をドラッグして、位置を変更可能にしてみた
//=============================================================================
procedure TForm1.Shape1MouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
 if Button = mbLeft then begin
    DragStartLeft := X;
    DragStartTop  := Y;
    Shape1.BeginDrag(True);
  end;
end;

//=============================================================================
//  Shape1のOnDragOverイベント
//  ドラッグ中の処理
//=============================================================================
procedure TForm1.Shape1DragOver(Sender, Source: TObject; X, Y: Integer;
  State: TDragState; var Accept: Boolean);
begin
  Accept := (Sender = Source);
  if Accept then begin
    Shape1.Left := Shape1.Left + X - DragStartLeft;
    Shape1.Top  := Shape1.Top  + Y - DragStartTop;
  end;
end;

//=============================================================================
//  Shape1のOnDragDropイベント
//  ドラッグ終了
//=============================================================================
procedure TForm1.Shape1DragDrop(Sender, Source: TObject; X, Y: Integer);
begin
  if (Sender = Source) then begin
    Shape1.Left := Shape1.Left + X - DragStartLeft;
    Shape1.Top  := Shape1.Top  + Y - DragStartTop;
    EndDrag(True);
    Button1Click(nil);
  end;
end;

end.



08_TShape をラバーバンドとして使う


上のメタファイルのサンプルでは、矩形範囲指定に TShape を使用しました。この TShape をラバーバンドの代わりに使うこともできます。そのサンプルです。

ラバーバンドとしては、拙作の[コントロール移動リサイズ]コンポーネントのように、グラブハンドルを持つ図形も使用されることもあります。


図18
設計時画面
  • TImage と TShape を配置
  • 起動時は、TShape を非表示にして、Brush.Style を bsClear にしておく
図19
実行中の画面
図20
実行結果例

リスト9
TShape をラバーバンドとして使う 
unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    Image1: TImage;
    Shape1: TShape;
    procedure FormCreate(Sender: TObject);
    procedure Image1MouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure Image1DragOver(Sender, Source: TObject; X, Y: Integer;
      State: TDragState; var Accept: Boolean);
    procedure Shape1EndDrag(Sender, Target: TObject; X, Y: Integer);
  private
    { Private 宣言 }
    InitX    : Integer;
    InitY    : Integer;
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

//=============================================================================
//  フォーム作成時の処理
//=============================================================================
procedure TForm1.FormCreate(Sender: TObject);
begin
  //ラバーバンド用のTShapeの初期設定
  Shape1.Visible     := False;
  Shape1.Brush.Style := bsClear;
  Shape1.Pen.Style   := psDot;
  Shape1.DragCursor  := crDefault;

  //Imgae1の画像をクリア(塗り潰し)
  Image1.Canvas.FillRect(Image1.ClientRect);
end;

//=============================================================================
//  Image1のOnMouseDownイベント
//  TShape(ラバーバンド)の描画開始
//=============================================================================
procedure TForm1.Image1MouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  if Button = mbLeft then begin
    InitX := X + Image1.Left;
    InitY := Y + Image1.Top;
    Shape1.SetBounds(InitX, InitY, 0, 0);
    Shape1.Show;
    Shape1.BeginDrag(False);
  end;
end;

//=============================================================================
//  Image1のOnDragOverイベント
//  マウスのドラッグにしたがって、TShape(ラバーバンド)のサイズを変更
//=============================================================================
procedure TForm1.Image1DragOver(Sender, Source: TObject; X, Y: Integer;
  State: TDragState; var Accept: Boolean);
var
  PosX : Integer;
  PosY : Integer;
begin
  if TComponent(Source).Name = 'Shape1' then begin
    PosX := X + Image1.Left;
    PosY := Y + Image1.Top;

    if PosX < InitX then Shape1.Left := PosX;
    Shape1.Width := Abs(PosX - InitX);

    if PosY < InitY then Shape1.Top := PosY;
    Shape1.Height := Abs(InitY - PosY);
  end;
end;

//=============================================================================
//  Shape1のEndDragイベント
//  Image1のイベントではないことに注意
//  描画終了
//=============================================================================
procedure TForm1.Shape1EndDrag(Sender, Target: TObject; X, Y: Integer);
var
  PosX : Integer;
  PosY : Integer;
begin
  if TComponent(Sender).Name = 'Shape1' then begin
    //TShapeを非表示
    Shape1.Hide;

    //ラバーバンドの最終サイズで四角形を描画
    Image1.Canvas.Pen.Mode  := pmCopy;
    Image1.Canvas.Pen.Color := clBlue;
    Image1.Canvas.Pen.Width := 5;

    PosX := InitX - Image1.Left;
    PosY := InitY - Image1.Top;

    Image1.Canvas.Brush.Color := clYellow;
    Image1.Canvas.Rectangle(PosX, PosY, X, Y);
  end;
end;

end.