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

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

Tate


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 = ',ダイハツ,いすゞ,BMW,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

|

その他のカテゴリー

ADO | ADT | API | ArrayList | ASP.NET | BDE | BDP.NET | BdpConnection | Borland Developer Studio 2006 | CAPICOM | class | ClipBoard | CodeEditor | Convert.ToString | Custom component | DBExpress | Delphi 2005 | Delphi 2006 | Delphi 2007 | Delphi XE2 | Delphi7 | Delphi8 | Device Driver | Dialog | Docking | DocuWorks | Docuworks SDK | Drag&Drop | Evernote | EXCEL | Firebird | FireMonkey | Game | General | Generics | Google Earth COM API | Google Maps | Google SketchUp | Graphic | IDE | Imm | Indy | InstallAware Express6 | InterBase Admin | JWW | Microsoft SQL Server | MyBase | OnMouseDown | Oracle XE | Paradox | PreviewHandler | PrintDialog | PrintPreviewDialog | PropertyGrid | PSDファイル | Ribbon Controls | RichTextBox | Servers | SubClass | TAction | TActionList | TAnimate | TButton | TCategoryButtons | TClientDataSet | TComboBox | TComboBoxEx | TCustomEdit | TDBGrid | TDockTabSet | TDrawGrid | TEdit | TExcelApplication | TFont | TForm | third party | TImage | TLabel | TList | TListBox | TListView | TMemo | TOpenDialog | TOutlookApplication | TPageControl | TPanel | TRichEdit | TShellResources | TStringGrid | TTabControl | TToolBar | TToolButton | TTreeView | TWebBrowser | Update | VCL Styles | WinInet | XE2 | XPman | オープン配列パラメータ | グループ化 | トランスレーションマネージャー | ファイル処理 | ファイル名処理 | 動的配列 | 投票 | 文字列処理 | 日本語入力 | 暗号 | | 音声合成利用