☆TStringGridでの縦書き(日本語)

マトリックス表を作るときに、横書きでは、幅が広くなりすぎて見づらいので、 縦書きを試してみました。アルファベット(RENAULT)が反対向いていますが、 今回、処理したかったのは日本語なので良しとしておきます(^^;
（BMWは全角で入力しています）

unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    StringGrid1: TStringGrid;
    procedure StringGrid1DrawCell(Sender: TObject; ACol, ARow: Integer;
      Rect: TRect; State: TGridDrawState);
    procedure FormCreate(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.FormCreate(Sender: TObject);
const
  S1 = ',トヨタ,日産,マツダ,ホンダ,スズキ,スバル,三菱';
  S2 = ',ダイハツ,いすゞ,ＢＭＷ,RENAULT,フォード';
var
  I, J: Integer;
  SL: TStringList;
begin
  // サンプルデータの設定
  SL:= TStringList.Create;
  try
    SL.CommaText := S1+S2;
    J := SL.Count;
    StringGrid1.ColCount := J;
    StringGrid1.Rows[0].Assign(SL);

    StringGrid1.RowCount := 3;
    StringGrid1.FixedCols := 1;
    StringGrid1.FixedRows := 1;
    StringGrid1.RowHeights[0] := 80;
    for I := 0 to J -1 do
      StringGrid1.ColWidths[I] := 25;
  finally
    SL.Free;
  end;
end;

procedure TForm1.StringGrid1DrawCell(Sender: TObject; ACol, ARow: Integer;
  Rect: TRect; State: TGridDrawState);

  // 縦書きの描画
  procedure VerticalTextDraw(S: String);
  var
    LF: TLogFont;
    I: Integer;
  begin
    StringGrid1.Canvas.Font.Height := 12;
    StringGrid1.Canvas.Font.Name := '@MS UI Gothic';

    GetObject(StringGrid1.Canvas.Font.Handle,SizeOf(LF), @LF);

    LF.lfEscapement := -900;
    StringGrid1.Canvas.Font.Handle := CreateFontIndirect(LF);
    I := ((Rect.Right - Rect.Left) div 2 + StringGrid1.Canvas.TextWidth('W'));
    StringGrid1.Canvas.TextOut(Rect.Left + I, Rect.Top + 5, S);
  end;

begin
  if (ARow = 0) then
  begin
    StringGrid1.Canvas.FillRect(Rect);
    VerticalTextDraw(StringGrid1.Cells[ACol,ARow]);
  end;
end;

end.

☆フォントの取得・描画

今更ですが、フォントを列挙するだけなら、次の処理で簡単にできます。

procedure TForm1.Button1Click(Sender: TObject);
begin
  ListBox1.Items.Assign(Screen.Fonts);
end;

その列挙したフォントをListBoxのDrawItemを使って、自分自身のフォントで描画させます。 このときCharSetを正しく設定しないと、きちんと描画できません。 次の処理では、SHIFTJIS_CHARSET以外はANSI_CHARSETと判断させていますが、正しくは全てのCharSetについて処理が必要です。 CharSetを取得させるため Screen.Fonts ではなくEnumFontFamProc API を使っています。

unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    ListBox1: TListBox;
    procedure ListBox1DrawItem(Control: TWinControl; Index: Integer;
      Rect: TRect; State: TOwnerDrawState);
    procedure ListBox1MeasureItem(Control: TWinControl; Index: Integer;
      var Height: Integer);
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
  private
    TempFont: TFont;
    procedure GetFontName;
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

// フォントを列挙する際に利用するアプリケーション定義のコールバック関数
function EnumFontFamProc(var EnumLogFont: TEnumLogFont;
  var NewTextMetric: TNewTextMetric;
  FontType: Integer; LPARAM: Longint): Integer; stdcall; export;
begin
  with Form1 do
  begin
    Result := 1;
    if (EnumLogFont.elfLogFont.lfCharSet = SHIFTJIS_CHARSET) then
      ListBox1.Items.AddObject(EnumLogFont.elfFullName, TObject(0))
    else
      ListBox1.Items.AddObject(EnumLogFont.elfFullName, TObject(1));
  end;
end;

// 初期設定
procedure TForm1.FormCreate(Sender: TObject);
begin
  TempFont := TFont.Create;
  SystemParametersInfo(SPI_SETLISTBOXSMOOTHSCROLLING, 0, nil, 0);
  ListBox1.Font.Size := 24;
  GetFontName;
end;

// 終了処理
procedure TForm1.FormDestroy(Sender: TObject);
begin
  TempFont.Free;
end;

// フォント名の取得
procedure TForm1.GetFontName;
begin
  ListBox1.Clear;
  EnumFontFamilies(Canvas.Handle, nil, @EnumFontFamProc, 0);
  ListBox1.Refresh;
end;

// フォントの描画
procedure TForm1.ListBox1DrawItem(Control: TWinControl; Index: Integer;
  Rect: TRect; State: TOwnerDrawState);
var
  S: String;
begin
  // CHARSETの設定
  if (Integer(ListBox1.Items.Objects[Index]) = 1) then
    ListBox1.Canvas.Font.Charset := ANSI_CHARSET
  else
    ListBox1.Canvas.Font.Charset := SHIFTJIS_CHARSET;
    
  // フォント名の設定
  ListBox1.Canvas.Font.Name := ListBox1.Items[Index];
  ListBox1.Canvas.Font.Size := ListBox1.Font.Size;
  ListBox1.Canvas.FillRect(Rect);

  // 描画
  S := ListBox1.Items[Index];
  DrawText(ListBox1.Canvas.Handle, PChar(S), -1, Rect,
    DT_LEFT or DT_SINGLELINE or DT_VCENTER);
end;

// ListBoxアイテムの高さを設定します。
procedure TForm1.ListBox1MeasureItem(Control: TWinControl; Index: Integer;
  var Height: Integer);

  // フォントの高さをピクセルで返します。
  function GetFontHeight(const F: TFont): Integer;
  begin
    Result := Abs(Trunc((-F.Size * F.PixelsPerInch) / 72))
      + (F.Size div  2); // 余白
  end;
begin
  if (Integer(ListBox1.Items.Objects[Index]) = 1) then
    TempFont.Charset := ANSI_CHARSET
  else
    TempFont.Charset := SHIFTJIS_CHARSET;
  TempFont.Name := ListBox1.Items[Index];
  TempFont.Size := ListBox1.Font.Size;
  Height := GetFontHeight(TempFont);
end;

end.

[参考にしたサイト]
MSDN
EnumFontFamProc