Delphi Programming / Object Pascal
サイトのトップページへ リンクのページへ ロゴマーク
[掲載 2009年04月06日] [更新 2014年01月23日]　Delphi サンプルプログラム集
172_メタファイルの基本動作テスト
動作確認等 Windows 7 U64(SP1) + Delphi XE Pro
172_MetaFile_BasicTest.zip　[3,904 KB]　2014年01月23日版 (EXE 同梱)



  • 2014年01月23日
  • サンプルコード内のサイズ再設定関係を削除してコードと記事を整備
  • Windows 98, 2000 でのテストは省略



メタファイルの基本動作テスト


メタファイルは，TCanvas へ描画する際に，StretchDraw 関数でサイズを変更してもギザギザにならないで滑らかに描画できます．写真のような画像には向いていませんが，いわゆるベクタ形式の画像，ベクタ図形で使用されています．
Delphi でメタファイル画像あるいは図形を作成するには，TMetaFile のインスタンスを生成して操作しますが，TBitmap のように 直接描画できる Canvas はありません．
  • (1) TMetaFile.Create でメタファイルのインスタンスを生成してサイズを設定
  • (2) このメタファイルから TMetaFileCanvas.Create でメタファイルの Canvas を生成
  • (3) 生成した TMetaFileCanvas に画像や図形を描画
  • (4) 描画が終了したら，TMetaFileCanvas.Free でインスタンスを解放
  • (5) メタファイルに描画内容が格納される
という手順で操作します．サイズを指定しないと，その時のデバイスコンテキストのサイズのメタファイルが作成されます．TMetaFileCanvas は TCanvas の派生クラスです．したがって，TCanvas のプロパティやメソッド類が全て使用可能です．
以下のテストでは，出力先のデバイスを全てディスプレイとしていますが，プリンタデバイスの場合とは多少異なることがあるかも知れません．

本ページのサンプルは全て，Image1.Aligin は alClient に，Stretch を True　にしています．





01_メタファイルのフォント幅の調整


Windows 95, 98 の時代，Windows のメタファイルはフォンド幅の設定が正しく反映されない現象がありました．Windows  Vista, 7 では問題ないようです．そこで，ここでは，中村拓男さんが提供しているフォント幅の調整コードを使用した場合と，使用しない場合を比較してみることにします．

下図は，作成した EXE を Windows XP(SP3) で実行した結果です．フォント幅の調整をしないと，文字と文字の間のスペースがなくなってしまっています．


図1
Windows XP でフォント幅調整なし
図2
Windows XP でフォント幅調整あり

次の図は，作成した EXEを Windows 7 U64(SP1) で実行した結果です．フォント幅の調整をしなくても文字間隔が正しく描画されていることが分かります．


図3
Window 7 でフォント幅調整なし
図4
Windows 7 でフォント幅調整あり
  • 実際にはフォント幅調整のコードは実行されていない

リスト1
メタファイルのフォント幅の調整をした場合としない場合の比較テスト		 
unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    Image1: TImage;
    Panel1: TPanel;
    Button1: TButton;
    Button2: TButton;
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
  private
    { Private 宣言 }
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

uses Types;

{$R *.dfm}

//=============================================================================
//  フォント幅の調整をしない場合
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
var
  LMetafile   : TMetafile;
  LMetaCanvas : TMetafileCanvas;
  LRect       : TRect;
  LuFormat    : Cardinal;
begin
  Image1.Picture := nil;

  //TMetaFileのインスタンスを作成
  LMetafile := TMetafile.Create;
  try
    //サイズの設定
    LMetafile.Width  := Image1.Width;
    LMetafile.Height := Image1.Height;

    //TMetaFileそのものはCanvasを持たない
    //TMetaFileCanvasを生成してここに描画する
    LMetaCanvas := TMetafileCanvas.Create(LMetafile, 0);
    try
      //フォントの設定
      LMetaCanvas.Font.Height := 90;
      LMetaCanvas.Font.Name   := 'ＭＳ ゴシック';

      //描画領域を指定してメタファイルCanvasへ描画
      //TextOutよりもDrawTextの方が描画位置の設定が簡単
      LRect    := Rect(0, 0, Image1.Width, Image1.Height);
      LuFormat := DT_CENTER or DT_VCENTER or DT_SINGLELINE;
      DrawText(LMetaCanvas.Handle, '文字列', -1, LRect, LuFormat);
    finally
      //メタファイルCanvasへの描画終了
      //メタファイルのCanvasを解放するとメタファイル画像ができる
      LMetaCanvas.Free;
    end;

    //作成したメタファイルをImage1に描画する
    Image1.Canvas.Draw(0, 0, LMetafile);
  finally
    LMetafile.Free;
  end;
end;

//=============================================================================
//  フォント幅の調整をする場合
//=============================================================================
procedure TForm1.Button2Click(Sender: TObject);

  //---------------------------------------------------------------------------
  //  フォント幅の調整用メソッド
  //  この処理が必要なのはWindows XP, Windows Vista
  //  Windows 2000/7/8/8.1/10では不要
  //---------------------------------------------------------------------------
  procedure AdjustFont(Canvas: TCanvas);
  var
    Ltm : TTextMetric;
    Llf : TLogFont;
  begin
    GetObject(Canvas.Font.Handle, SizeOf(Llf), @Llf);
    if Llf.lfWidth = 0 then begin
      GetTextMetrics(Canvas.Handle, Ltm);
      Llf.lfWidth := -Llf.lfHeight * Ltm.tmAveCharWidth div Ltm.tmHeight;
      Canvas.Font.Handle := CreateFontIndirect(Llf);
    end;
  end;
  //---------------------------------------------------------------------------

var
  LMetafile   : TMetafile;
  LMetaCanvas : TMetafileCanvas;
  LRect       : TRect;
  LuFormat    : Cardinal;
begin
  Image1.Picture := nil;

  //TMetaFileのインスタンスを作成
  LMetafile := TMetafile.Create;
  try
    //サイズを設定する
    LMetafile.Width  := Image1.Width;
    LMetafile.Height := Image1.Height;

    //TMetaFileそのものはCanvasを持たない
    //TMetaFileCanvasを生成してここに描画する
    LMetaCanvas := TMetafileCanvas.Create(LMetafile, 0);
    try
      //フォントの設定
      LMetaCanvas.Font.Height := 90;
      LMetaCanvas.Font.Name   := 'ＭＳ ゴシック';

      //文字幅を適切にする
      AdjustFont(LMetaCanvas);

      //描画領域を指定してメタファイルCanvasへ描画
      //TextOutよりもDrawTextの方が描画位置の設定が簡単
      LRect    := Rect(0, 0, Image1.Width, Image1.Height);
      LuFormat := DT_CENTER or DT_VCENTER or DT_SINGLELINE;
      DrawText(LMetaCanvas.Handle, '文字列', -1, LRect, LuFormat);
    finally
      //メタファイルCanvasへの描画終了
      //メタファイルのCanvasを解放するとメタファイル画像ができる
      LMetaCanvas.Free;
    end;

    //作成したメタファイルをImage1に描画する
    Image1.Canvas.Draw(0, 0, LMetafile);
  finally
    LMetafile.Free;
  end;
end;

end.



02_背景を塗り潰して文字列を描画 - TImage.Draw


メタファイルの Canvas を塗潰してから文字列を描画する例です．
文字列はメタファイルの Canvas の上下中央に描画しています．このサンプルでは，作成したメタファイルを Image1 へ Draw メソッドで描画しています．TImage に描画したのはメタファイルですが，拡大するとギザギザになっています．次項のサンプルの結果と比較してみてください．


図5
実行画面
図6
拡大画像

リスト2
作成したメタファイルを TImage の Canvas へ Draw メソッドで描画		 
unit Unit1;

interface

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

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

var
  Form1: TForm1;

implementation

uses Types;

{$R *.dfm}

//=============================================================================
//  メタファイルのCanvasを塗り潰す場合
//  TImageにDrawメソッドでメタファイルを描画
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);

  //---------------------------------------------------------------------------
  //  フォント幅の調整用メソッド
  //  この処理が必要なのはWindows XP, Windows Vista
  //  Windows 2000/7/8/8.1/10では不要
  //---------------------------------------------------------------------------
  procedure AdjustFont(Canvas: TCanvas);
  var
    Ltm : TTextMetric;
    Llf : TLogFont;
  begin
    GetObject(Canvas.Font.Handle, SizeOf(Llf), @Llf);
    if Llf.lfWidth = 0 then begin
      GetTextMetrics(Canvas.Handle, Ltm);
      Llf.lfWidth := -Llf.lfHeight * Ltm.tmAveCharWidth div Ltm.tmHeight;
      Canvas.Font.Handle := CreateFontIndirect(Llf);
    end;
  end;
  //---------------------------------------------------------------------------

var
  LMetafile   : TMetafile;
  LMetaCanvas : TMetafileCanvas;
  LRect       : TRect;
  LuFormat    : Cardinal;
begin
  Image1.Picture := nil;

  //TMetaFileのインスタンスを作成
  LMetafile := TMetafile.Create;
  try
    //サイズを設定する
    LMetafile.Width  := Image1.Width;
    LMetafile.Height := Image1.Height;

    //TMetaFileそのものはCanvasを持たない
    //TMetaFileCanvasを生成してここに描画する
    LMetaCanvas := TMetafileCanvas.Create(LMetafile, 0);
    try
      //フォントの設定
      LMetaCanvas.Font.Height := 60;
      LMetaCanvas.Font.Name   := 'ＭＳ ゴシック';

      //Canvasを塗潰す
      LMetaCanvas.Pen.Style   := psSolid;
      LMetaCanvas.Brush.Color := $009EE9AA;
      LMetaCanvas.FillRect(LMetaCanvas.ClipRect);

      //文字幅を適切にする
      AdjustFont(LMetaCanvas);

      //描画領域を指定してメタファイルCanvasへ描画
      //TextOutよりもDrawTextの方が描画位置の設定が簡単
      LRect    := Rect(0, 0, Image1.Width, Image1.Height);
      LuFormat := DT_CENTER or DT_VCENTER or DT_SINGLELINE;
      DrawText(LMetaCanvas.Handle, '文字列', -1, LRect, LuFormat);
    finally
      //メタファイルCanvasへの描画終了
      //メタファイルのCanvasを解放するとメタファイル画像ができる
      LMetaCanvas.Free;
    end;

    //作成したメタファイルをImage1に描画する
    Image1.Canvas.Draw(0, 0, LMetafile);
  finally
    LMetafile.Free;
  end;
end;

end.



03_背景を塗り潰して文字列を描画 - TImage.Picture.Assign


今度は，作成したメタファイルを TImage に描画する際，Picture.Assign で代入します．上のサンプルで変更したのは，下のコードの部分だけです．
拡大してもギザギザになりませんが，Picture.Assign で描画した場合は，TImage の Canvas への追加描画はできません．


図7
実行結果
図8
拡大した結果

リスト3
作成したメタファイルを TImage へ Picture.Assign で描画		 
    //作成したメタファイルをImage1に描画する
    Image1.Picture.Assign(LMetafile);



04_背景の塗り潰しなしで文字列を描画


次は，メタファイルの Canvas を塗潰さないで文字列を描画した場合です．
文字列の背景が白くなり，他の部分は透過状態になります．


図9
実行結果
  • 文字列の背景が白くなっている

リスト4
メタファイルの Canvas を塗潰さないで文字列描画 
unit Unit1;

interface

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

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

var
  Form1: TForm1;

implementation

uses Types;

{$R *.dfm}

//=============================================================================
//  背景の塗り潰しなしで文字列を描画
//  TImageにPicture.Assignでメタファイルを描画
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);

  //---------------------------------------------------------------------------
  //  フォント幅の調整用メソッド
  //  この処理が必要なのはWindows XP, Windows Vista
  //  Windows 2000/7/8/8.1/10では不要
  //---------------------------------------------------------------------------
  procedure AdjustFont(Canvas: TCanvas);
  var
    Ltm : TTextMetric;
    Llf : TLogFont;
  begin
    GetObject(Canvas.Font.Handle, SizeOf(Llf), @Llf);
    if Llf.lfWidth = 0 then begin
      GetTextMetrics(Canvas.Handle, Ltm);
      Llf.lfWidth := -Llf.lfHeight * Ltm.tmAveCharWidth div Ltm.tmHeight;
      Canvas.Font.Handle := CreateFontIndirect(Llf);
    end;
  end;
  //---------------------------------------------------------------------------

var
  LMetafile   : TMetafile;
  LMetaCanvas : TMetafileCanvas;
  LRect       : TRect;
  LuFormat    : Cardinal;
begin
  Image1.Picture := nil;

  //TMetaFileのインスタンスを作成
  LMetafile := TMetafile.Create;
  try
    //サイズを設定する
    LMetafile.Width  := Image1.Width;
    LMetafile.Height := Image1.Height;

    //TMetaFileそのものはCanvasを持たない
    //TMetaFileCanvasを生成してここに描画する
    LMetaCanvas := TMetafileCanvas.Create(LMetafile, 0);
    try
      //フォントの設定
      LMetaCanvas.Font.Height := 60;
      LMetaCanvas.Font.Name   := 'ＭＳ ゴシック';

      //文字幅を適切にする
      AdjustFont(LMetaCanvas);

      //描画領域を指定してメタファイルCanvasへ描画
      //TextOutよりもDrawTextの方が描画位置の設定が簡単
      LRect    := Rect(0, 0, Image1.Width, Image1.Height);
      LuFormat := DT_CENTER or DT_VCENTER or DT_SINGLELINE;
      DrawText(LMetaCanvas.Handle, '文字列', -1, LRect, LuFormat);
    finally
      //メタファイルCanvasへの描画終了
      //メタファイルのCanvasを解放するとメタファイル画像ができる
      LMetaCanvas.Free;
    end;

    //作成したメタファイルをImage1に描画する
    Image1.Picture.Assign(LMetafile);
  finally
    LMetafile.Free;
  end;
end;

end.



05_文字列部分の背景を透過して描画


文字列部分の背景を透過状態にするには，文字列を描画する前に，メタファイルの Canvas の Brush を透過設定をします．以下のコードでは，SetBkMode 関数を使用して透過に設定しています．

これまでのテストの結果，メタファイルを作成して，TImage 等に表示して，拡大してもギザギザにならないようにするには，Picture.Assign を使用すればいいことが分かります．そのためには，メタファイルの Canvas に必要な文字列，図形等を描画したメタファイルを作成してから，TImage 等に表示します．文字列の背景を透過状態にするには，SetBkMode 関数等を使用します．
必要であれば，文字列や図形を描画する前にメタファイルの Canvas を塗り潰します．塗り潰さない場合は，描画部分以外は透過し，TImage 等に表示した時に「透ける」ことになります．



図10
実行結果
  • 文字列の背景が透過されている

リスト5
文字列部分の背景を透過状態にする		 
      //描画領域を指定してメタファイルCanvasへ描画
      //TextOutよりもDrawTextの方が描画位置の設定が簡単
      LRect    := Rect(0, 0, Image1.Width, Image1.Height);
      LuFormat := DT_CENTER  or DT_VCENTER or DT_SINGLELINE;
      SetBkMode(LMetaCanvas.Handle, TRANSPARENT);
      DrawText(LMetaCanvas.Handle, '文字列', -1, LRect, LuFormat);



06_メタファイルのクリップリージョン


メタファイルの Canvas (TMetaFileCanvas) には，他の Canvas 同様，リージョンも使用できます．
そのテストです．楕円で描画領域をクリップし，その外側には描画しないようにしています．



図11
設計時画面
図12
実行結果
  • 楕円でクリップされている
図13
拡大表示
  • メタファイル内のリージョンも変形する

リスト6
メタファイルでリージョン 
unit Unit1;

interface

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

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

var
  Form1: TForm1;

implementation

{$R *.dfm}

//=============================================================================
//  メタファイルのキャンバスにもリージョンが使用できることを確認
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);

  //---------------------------------------------------------------------------
  //  フォント幅の調整用メソッド
  //  この処理が必要なのはWindows XP, Windows Vista
  //  Windows 2000/7/8/8.1/10では不要
  //---------------------------------------------------------------------------
  procedure AdjustFont(Canvas: TCanvas);
  var
    Ltm : TTextMetric;
    Llf : TLogFont;
  begin
    GetObject(Canvas.Font.Handle, SizeOf(Llf), @Llf);
    if Llf.lfWidth = 0 then begin
      GetTextMetrics(Canvas.Handle, Ltm);
      Llf.lfWidth := -Llf.lfHeight * Ltm.tmAveCharWidth div Ltm.tmHeight;
      Canvas.Font.Handle := CreateFontIndirect(Llf);
    end;
  end;
  //---------------------------------------------------------------------------

var
  LMetafile   : TMetafile;
  LMetaCanvas : TMetafileCanvas;
  LRect       : TRect;
  LRgn        : HRGN;
  LrgnRect    : TRect;
  LuFormat    : Cardinal;
begin
  Image1.Picture := nil;

  LMetafile := TMetafile.Create;
  try
    LMetafile.Width  := Image1.Width;
    LMetafile.Height := Image1.Height;

    LMetaCanvas := TMetafileCanvas.Create(LMetafile, 0);
    try
      LRect := Rect(0, 0, Image1.Width, Image1.Height);

      //楕円のクリップリージョンを作成
      LrgnRect        := LRect;
      LrgnRect.Top    := LrgnRect.Top + 20;
      LrgnRect.Bottom := LrgnRect.Bottom - 20;
      LRgn  := CreateEllipticRgnIndirect(LrgnRect);
      //そのリージョンをメタファイルのCanvasに適用する
      SelectClipRgn(LMetaCanvas.Handle, LRgn);
      //Canvasに書き込んだらハンドルは削除
      DeleteObject(LRgn);

      //クリップの状態を見やすくするためにメタファイルCanvasを塗潰し
      LMetaCanvas.Pen.Style   := psSolid;
      LMetaCanvas.Brush.Color := $00D7E1CA;
      LMetaCanvas.FillRect(LRect);

      LMetaCanvas.Font.Height := 120;
      LMetaCanvas.Font.Name   :='ＭＳ ゴシック';
      AdjustFont(LMetaCanvas);

      LuFormat := DT_CENTER or DT_VCENTER or DT_SINGLELINE;
      SetBkMode(LMetaCanvas.Handle, TRANSPARENT);
      DrawText(LMetaCanvas.Handle, '文字列', -1, LRect, LuFormat);
    finally
      LMetaCanvas.Free;
    end;
    Image1.Picture.Assign(LMetafile);
  finally
    LMetafile.Free;
  end;
end;

end.



07_反転ミラー文字列


反転ミラー文字を描画する例です．
メタファイルでは，上下左右の座標値を入れ換えることができます．このサンプルでは，文字列と同じサイズのメタファイルを作成し，更に，その同じサイズの矩形領域に PlayEnhMetaFile 関数を用いて描画しています．TImage の Canvas に Draw 関係の描画メソッドで描画してるので，拡大するとギザギザになります．
フォームのサイズ (TImage のサイズ) を変更後，再描画すれば，その時の解像度で表示できます．

Windows 9X ではこの機能は使用できません．


図14
設計時画面
図15
左右反転文字列
図16
上下反転文字列

リスト7
反転ミラー文字列 
unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    Image1: TImage;
    Button1: TButton;
    Button2: TButton;
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
  private
    procedure StretchDrawMetaFile(ARect: TRect; Text: String;
      AFont: TFont);
    procedure SwapIntValue(var A, B: Integer);
    { Private 宣言 }
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

//====================================================================
//  左右反転ミラー文字列
//====================================================================
procedure TForm1.Button1Click(Sender: TObject);
var
  LFont     : TFont;
  LX1       : Integer;
  LX2       : Integer;
  LY1       : Integer;
  LY2       : Integer;
  LHeight   : Integer;
  LLength   : Integer;
  LTestText : String;
begin
  Image1.Picture := nil;

  LTestText := '反転文字列';

  LFont   := TFont.Create;
  LHeight := Image1.Height div 4;
  try
    LX1 := 40;
    LY1 := 45;
    LY2 := LY1 + LHeight;

    //通常の文字の描画
    Image1.Canvas.Font.Color  := clBlack;
    Image1.Canvas.Font.Height := LY2 - LY1;
    Image1.Canvas.TextOut(LX1, LY1, LTestText);

    //文字列の長さを求める
    LLength := Image1.Canvas.TextWidth(LTestText);
    LX2     := LX1+LLength;
    //文字列を囲む枠を描画
    Image1.Canvas.Brush.Style := bsClear;
    Image1.Canvas.Rectangle(LX1, LY1, LX2, LY2);

    //反転文字の色
    LFont.Assign(Image1.Canvas.Font);
    LFont.Color := clGreen;

    //左右反転ミラーの指定(X座標の左右を入換える)
    //上下反転ミラー文字列作成との違いはここだけ
    LY1 := LY2 + 10;
    LY2 := LY1 + LHeight;
    SwapIntValue(LX1, LX2);
    //LFontで指定するフォントでImage1上ににメタファイル作成してを描画
    StretchDrawMetaFile(Rect(LX1, LY1, LX2, LY2), LTestText, LFont);

    //文字列を囲む枠を描画
    Image1.Canvas.Pen.Color := clRed;
    Image1.Canvas.Rectangle(LX1, LY1, LX2, LY2);
  finally
    FreeAndNil(LFont);
  end;
end;

//====================================================================
//  上下反転ミラー文字列
//====================================================================
procedure TForm1.Button2Click(Sender: TObject);
var
  LFont     : TFont;
  LX1       : Integer;
  LX2       : Integer;
  LY1       : Integer;
  LY2       : Integer;
  LHeight   : Integer;
  LLength   : Integer;
  LTestText : String;
begin
  Image1.Picture := nil;

  LTestText := '反転文字列';

  LFont   := TFont.Create;
  LHeight := Image1.Height div 4;
  try
    LX1 := 40;
    LY1 := 45;
    LY2 := LY1 + LHeight;

    //通常の文字の描画
    Image1.Canvas.Font.Color  := clBlack;
    Image1.Canvas.Font.Height := LY2 - LY1;
    Image1.Canvas.TextOut(LX1, LY1, LTestText);

    //文字列の長さを求める
    LLength := Image1.Canvas.TextWidth(LTestText);
    LX2     := LX1+LLength;
    //文字列を囲む枠を描画
    Image1.Canvas.Brush.Style := bsClear;
    Image1.Canvas.Rectangle(LX1, LY1, LX2, LY2);

    //反転文字の色
    LFont.Assign(Image1.Canvas.Font);
    LFont.Color := clGreen;

    //上下反転ミラーの指定(X座標の左右を入換える)
    //左右反転ミラー文字列作成との違いはここだけ
    LY1 := LY2 + 10;
    LY2 := LY1 + LHeight;
    SwapIntValue(LY1, LY2);
    //LFontで指定するフォントでImage1上ににメタファイル作成してを描画
    StretchDrawMetaFile(Rect(LX1, LY1, LX2, LY2), LTestText, LFont);

    //文字列を囲む枠を描画
    Image1.Canvas.Pen.Color := clRed;
    Image1.Canvas.Rectangle(LX1, LY1, LX2, LY2);
  finally
    FreeAndNil(LFont);
  end;
end;

//=============================================================================
//  文字列をメタファイルで作成し,引数で指定するRect範囲に描画する関数
//  ここではメタファイルのサイズを文字列を囲む範囲の大きさで作成
//============================================================================
procedure TForm1.StretchDrawMetaFile(ARect: TRect; Text: String; AFont: TFont);

  //---------------------------------------------------------------------------
  //  フォント幅の調整用メソッド
  //  この処理が必要なのはWindows XP, Windows Vista
  //  Windows 2000/7/8/8.1/10では不要
  //---------------------------------------------------------------------------
  procedure AdjustFont(Canvas: TCanvas);
  var
    Ltm : TTextMetric;
    Llf : TLogFont;
  begin
    GetObject(Canvas.Font.Handle, SizeOf(Llf), @Llf);
    if Llf.lfWidth = 0 then begin
      GetTextMetrics(Canvas.Handle, Ltm);
      Llf.lfWidth := -Llf.lfHeight * Ltm.tmAveCharWidth div Ltm.tmHeight;
      Canvas.Font.Handle := CreateFontIndirect(Llf);
    end;
  end;
  //---------------------------------------------------------------------------

var
  LMetaFile : TMetafile;
  LCanvas   : TMetaFileCanvas;
  LWidth    : Integer;
  LHeight   : Integer;
begin
  LMetaFile      := TMetafile.Create;
  LMetaFile.Inch := 0;

  try
    LCanvas  := TMetafileCanvas.Create(LMetaFile, 0);
    try
      //メタファイルに必要なサイズを求める
      LCanvas.Font.Assign(AFont);
      //フォントを正しく設定
      AdjustFont(LCanvas);
      LWidth  := LCanvas.TextWidth(Text);
      LHeight := LCanvas.TextHeight(Text);
      //一旦描画を終了してメタファイルのサイズを設定
      LCanvas.Free;
      LMetaFile.Width  := LWidth;
      LMetaFile.Height := LHeight;

      //メタファイルCanvasを再生成
      LCanvas  := TMetafileCanvas.Create(LMetaFile, 0);
      LCanvas.Font.Assign(AFont);
      //フォントを正しく設定
      AdjustFont(LCanvas);

      LCanvas.Brush.Style := bsClear;
      LCanvas.TextOut(0, 0, Text);
    finally
      LCanvas.Free;
    end;
    //複雑またはサイズの大きなメタファイルあるいは高速処理等の場合,この関数で
    //ないと画像落ち等が発生することがある
    PlayEnhMetaFile(Image1.Canvas.Handle, LMetaFile.Handle, ARect);
  finally
    LMetaFile.Free;
  end;
end;

//=============================================================================
//  変数の交換(入替え)関数
//=============================================================================
procedure TForm1.SwapIntValue(var A, B: Integer);
var
  LTemp : Integer;
begin
  LTemp := A;
  A := B;
  B := LTemp;
end;

end.