Delphi Programming / Object Pascal
サイトのトップページへ リンクのページへ ロゴマーク
[掲載 2009年02月14日] [更新 2012年10月18日] コントロール移動リサイズコンポーネント
コントロール移動リサイズコンポーネント
テストプログラム MetaFileString
動作確認等 Windows 7 U64(SP1) + Delphi XE Pro







メタファイルを利用したリサイズ可能な文字列


サンプルプログラム集[170_MetaFile描画でImageサイズ調整]のコードを利用して,文字列のサイズと位置変更を可能にするテストプログラムです.


図1
設計時画面
  • 配置コントロールは以下の通り
    TplDragResize
    TButton
    TImage
図2
実行画面
  • ボタンをクリックして文字列を選択
図3
大きく拡大
  • メタファイルなのでギザギザなし

リスト1
移動リサイズ可能な文字列の例
unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    plDragResize1: TplDragResize;
    Image1: TImage;
    Button1: TButton;
    procedure FormCreate(Sender: TObject);
    procedure Button1Click(Sender: TObject);
    procedure Image1MouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure FormMouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
  private
    { Private 宣言 }
    procedure MakeMetaFileFitImageSize(AImage: TImage; AText: String; AFont: TFont);
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

//=============================================================================
//  フォーム生成時の処理
//=============================================================================
procedure TForm1.FormCreate(Sender: TObject);
begin
  Caption := '移動リサイズ可能な文字列';
end;

//=============================================================================
//  [生成・選択]ボタン
//  1. 指定文字列を指定フォントで描画したメタフィルを作成して,TImageに表示
//  2. TImageの表示位置を指定
//  3. 選択状態にして移動リサイズ可能にする
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
var
    AFont : TFont;
begin
  if Image1.Picture.Graphic = nil then begin
    AFont := TFont.Create;
    try
      AFont.Assign(Self.Canvas.Font);
      AFont.Size := 50;
      MakeMetaFileFitImageSize(Image1, '文字列', AFont);
      Image1.Left := 50;
      Image1.Top  := 80;
    finally
      FreeAndNil(AFont);
    end;
  end;

  plDragResize1.Target := Image1;
end;

//=============================================================================
//  Image1のMouseDownイベント処理
//  マウス左ボタンダウンでTplDragResizeコンポのTargetを指定
//=============================================================================
procedure TForm1.Image1MouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  if Button = mbLeft then begin
    plDragResize1.Target := TControl(Sender);
  end;
end;

//=============================================================================
//  plDragResizeコンポの親であるフォームのMouseDownイベント処理
//  コントロールの選択状態を解除
//=============================================================================
procedure TForm1.FormMouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  plDragResize1.Target := nil;
end;

//=============================================================================
//  文字列だけのメタファイルを作成してTImageのサイズに合わせて表示
//
//  メタファイル画像であれば,AImage.Picture.Assign()で表示できるが,図形等は
//  TMetaFileCanvasを生成して作成しなければならない
//=============================================================================
procedure TForm1.MakeMetaFileFitImageSize(AImage: TImage; AText: String;
  AFont: TFont);
var
  AMetaFile : TMetafile;
  ACanvas   : TMetaFileCanvas;
  AWidth    : Integer;
  AHeight   : Integer;
  ARect     : TRect;
  DrawFlag  : Cardinal;
begin
  AImage.Picture.Assign(nil);
  AMetaFile := TMetafile.Create;
  AMetaFile.Enhanced := TRue;
  try
    ACanvas := TMetafileCanvas.Create(AMetaFile, Image1.Canvas.Handle);
    try
      ACanvas.Font.Assign(AFont);
      AWidth  := ACanvas.TextWidth(AText);
      AHeight := ACanvas.TextHeight(AText);
    finally
      ACanvas.Free;
    end;

    AMetaFile.Width  := AWidth;
    AMetaFile.Height := AHeight;

    ACanvas := TMetafileCanvas.Create(AMetaFile, Image1.Canvas.Handle);
    try
      ACanvas.Font.Assign(AFont);
      ACanvas.Brush.Style := bsClear;

      ARect := Rect(0, 0, AWidth, AHeight);
      ACanvas.FillRect(ARect);
      DrawFlag := DT_SINGLELINE or DT_CENTER or DT_VCENTER;
      DrawText(ACanvas.Handle, PChar(AText), -1, ARect, DrawFlag);
    finally
      ACanvas.Free;
    end;
    AImage.SetBounds(0, 0, AWidth, AHeight);
    AImage.Picture.Assign(AMetaFile);
  finally
    AMetaFile.Free;
  end;
end;

end.