Delphi Programming / Object Pascal
[掲載 2005年01月01日] [更新 2012年08月06日] Delphi サンプルプログラム集 |
170_文字サイズに応じた TMetaFile の作成とイメージサイズ調整 |
動作確認等 |
Windows XP(SP3) + Delphi XE Pro
Windows 7 U64(SP1) + Delphi XE Pro |
|
170_ImageMetaFile.zip [556 KB] 2012年08月06日版 (EXE 同梱) |
- 2009年02月13日
- フォントの幅設定用メソッドを追加して文字間のスペースがなくなる現象を防止.
印刷プレビュー制御コンポーネントは,内部でプリンタの情報からフォント情報を初期化しているので,この現象は発生しない.
- 2009年03月04日
- 最初のメタファイル生成でAdjustFontが抜けていたのを修正
- 2012年08月06日
- Windows U64(SP1) + Delphi XE で動作確認
- 描画開始位置が左上からとなっていたのを,上下左右中心に修正
|
文字列サイズに応じたメタファイルの作成とイメージサイズ調整 |
メタファイルの文字列は,TImageなどのCanvasに描画して拡大縮小してもその品質が保たれ便利です.しかし,メタファイルを作成する時点では,そのサイズを文字列に合わせることはできません.そこで,このサンプルプログラムでは,文字列の大きさに応じたメタファイルを作成する一つの方法を考えてみました.また,このメタファイルのサイズにTImageのサイズも調整します.このサンプルでは,斜体フォントの場合を考慮していません.必要であれば,「斜体フォントの幅」を参考にして下さい.
この手法は,拙作印刷プレビューコンポーネントで使用しています.
コード中の,AdjustFont というフォント幅の調整用関数ですが,Windows XP(SP3) の初期のバージョンでは必要でしたが,最新の Windows Update では修正されているようです.Windows Vista, 7 ではこの関数の処理は必要ありません. |
|
図1
設計時画面
- 以下のコンポーネントを配置
TImage
TButtonを2つ
|
|
図2
実行して作成
- 文字列サイズに応じたメタファイル作成
- そのサイズでTImaegのサイズを調整
|
|
図3
拡大表示
|
文字列は,日本語フォントと,その他のフォントでは構造(メトリック)が違います.上は,[Tahoma] の場合です.これを [MS ゴシック]にして実行したのが下の図です.文字本体のサイズが違っているのが分かります.
このため,TMemo 等でテキストを表示すると,MS ゴシックでは行間が狭くなりますが,Tahoma を使用すると,日本語文字でも少し行間が広くなります. |
|
図4
MS ゴシックの場合 |
リスト1
文字列サイズに応じたメタファイルの作成とイメージサイズ調整 |
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 := 'MS Pゴシック';
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.
|