unit ImageMetaFileUnit;

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
    { Private 宣言 }
    procedure FitImageSize(AImage: TImage; Str: String; AFont: TFont);
    procedure AdjustFont(Canvas : TCanvas);
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

//=============================================================================
//  FitImageSizeメソッドを使用してImageに文字列のメタファイルを表示
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
var
  AFont: TFont;
begin
  AFont := TFont.Create;
  try
    AFont.Size := 20;
    //AFont.Name := 'ＭＳ Ｐゴシック';
    FitImageSize(Image1, '談話室', AFont);
  finally
    FreeAndNil(AFont);
  end;
end;

//=============================================================================
//  Imageを拡大してみる
//  表示はAssignで行っていて、内容はメタファイルなので拡大してもギザギザになら
//  ない。ただし、ImageのCanvasにStrechDraw,Drawする場合と違い、IamgeのCanvasへ
//  追加描画はできない。
//=============================================================================
procedure TForm1.Button2Click(Sender: TObject);
begin
  Image1.Width  := 230;
  Image1.Height := 130;
end;

//=============================================================================
//  文字列だけのメタファイルをImageに表示
//  必要なメタファイルのサイズを予め知ることができないので、一度作成したメタフ
//  ァイルCanvasでサイズを調査して再度MetaFileCanvasを生成する方法を使用。
//  Imageのサイズもこの調査したサイズに合わせる。
//=============================================================================
procedure TForm1.FitImageSize(AImage: TImage; Str: String; AFont: TFont);
var
  AMetaFile : TMetafile;
  ACanvas   : TMetaFileCanvas;
  AWidth    : Integer;
  AHeight   : Integer;
  ARect     : TRect;
begin
  AImage.Picture.Assign(nil);
  AMetaFile := TMetafile.Create;
  AMetaFile.Inch := 0;

  try
    ACanvas := TMetafileCanvas.Create(AMetaFile, 0);
    try
      //メタファイルに必要なサイズを求める
      ACanvas.Font.Assign(AFont);
      AWidth  := ACanvas.TextWidth(Str);
      AHeight := ACanvas.TextHeight(Str);
      //一旦描画を終了してメタファイルのサイズを設定
      ACanvas.Free;
      AMetaFile.Width  := AWidth;
      AMetaFile.Height := AHeight;

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

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

//=============================================================================
//  フォントの縦横サイズが正確に取得できない現象の回避関数
//  フォント幅が0の時に文字幅を設定する
//  中村拓男著「Delphi Graphic Secrets」P141のコードそのまま
//=============================================================================
procedure TForm1.AdjustFont(Canvas: TCanvas);
var
  tm : TTextMetric;
  lf : TLogFont;
begin
  GetObject(Canvas.Font.Handle, SizeOf(lf), @lf);
  if lf.lfWidth = 0 then begin
    GetTextMetrics(Canvas.Handle, tm);
    lf.lfWidth := -lf.lfHeight * tm.tmAveCharWidth div tm.tmHeight;
    Canvas.Font.Handle := CreateFontIndirect(lf);
  end;
end;

end.