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.

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.

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.

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.

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.

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.

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.