☆ListBoxのlbOwnerDrawVariableの不思議？

ListBoxの各アイテム毎の高さを変えて表示するには、StyleプロパティをlbOwnerDrawVariableに設定し、OnDrawItem、OnMeasureItemイベントの処理を書きます。 しかしそれだけでは OnMeasureItem が発生せず、なぜかMultiSelectをTrueにする必要があるようです。 高さが可変なのと複数行選択には、関連がなさそうなのですけど仕様なのでしょうか。 いつもMultiSelectがTrueの状態で使っていたので、今まで気付きませんでした。

又、アイテムの高さには制限があるようです。これについて少し調べてみました。 下記のようなプログラムを作成して、どこまできちんと描画されているかを確認しました。

ボタンを押すとフォントのサイズが１つ大きくなり、再描画するようにしています。

unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    ListBox1: TListBox;
    Memo1: TMemo;
    Panel1: TPanel;
    Button1: TButton;
    Edit1: TEdit;
    procedure ListBox1MeasureItem(Control: TWinControl; Index: Integer;
      var Height: Integer);
    procedure ListBox1DrawItem(Control: TWinControl; Index: Integer;
      Rect: TRect; State: TOwnerDrawState);
    procedure FormCreate(Sender: TObject);
    procedure Button1Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}


procedure SetSample;
var
  I :Integer;
begin
  with Form1 do
  begin
    ListBox1.Font.Size := ListBox1.Font.Size + 1;
    Edit1.Text := IntToStr(ListBox1.Font.Size);

    Memo1.Lines.Clear;
    ListBox1.Items.Clear;
    for I := 0 to 80 do
      ListBox1.Items.Add(IntToStr(I));
    ListBox1.ItemIndex := 0;
  end;
end;

function GetRowCount(Index: Integer): Integer;
begin
  Result := Index mod 30;
end;

function GetFontHeight: Integer;
begin
  with Form1 do
  Result := Abs(Trunc((-ListBox1.Font.Size *
    ListBox1.Font.PixelsPerInch) / 72)) + 4;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  ListBox1.Font.Size := 7;
  SetSample;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  SetSample;
end;

procedure TForm1.ListBox1DrawItem(Control: TWinControl; Index: Integer;
  Rect: TRect; State: TOwnerDrawState);
var
  I, J, Row: Integer;
begin
  // 行がわかりやすいように色を変えます
  if Index mod 2 = 0 then
  begin
    ListBox1.Canvas.Brush.Color := clwhite;
    ListBox1.Canvas.Font.Color := clBlue;
  end
  else
  begin
    ListBox1.Canvas.Brush.Color := $00D3F8FF;
    ListBox1.Canvas.Font.Color := clBlack;
  end;

  ListBox1.Canvas.FillRect(Rect);
  Row := GetRowCount(Index+1);
  for I := 0 to Row - 1 do
  begin
    J := Rect.Top + GetFontHeight * I;
    ListBox1.Canvas.TextOut(Rect.Left, J, Format('Item%d',[Index+1]));
  end;
end;

procedure TForm1.ListBox1MeasureItem(Control: TWinControl; Index: Integer;
  var Height: Integer);
begin
  Height := GetFontHeight * GetRowCount(Index+1) ;
  Memo1.LInes.Add(Format('%d---%d',[Index+1, Height]) );
end;

end.

[Font.Size := 8 の場合] 252の高さまで、正常に表示されています。

[Font.Size := 9 の場合] 256の高さで、アイテムは表示すらされていません。

[Font.Size := 10 の場合] 255の高さまで、正常に表示されています。

他のサイズも同じように調べ、その結果からわかったことは、OnMeasureItemのHeightは256未満でないと、 この処理では描画できないということです。 （256の場合には、表示すらされていません。）
でもlbOwnerDrawFixedの場合は、ItemHeightに256を入れても問題なく動作しているんですよね。
可変高さで、全ての項目を表示したい場合には、ListBoxをあきらめてStringGridを使うか、最終行に「省略されています」というような表示が必要に なりますね。

☆フォントの取得・描画

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

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

☆ListBoxのDrawItem No2

前回は、ListBoxのバグをアニメーション表示を無効にすることで回避しましたが、フォームのMouseWheelDown、 MouseWheelUpを使って、次のような処理でも回避できます。

procedure TForm1.FormMouseWheelDown(Sender: TObject; Shift: TShiftState;
  MousePos: TPoint; var Handled: Boolean);
const
  Value = 1;
begin
  if (ActiveControl is TListBox) and
    ((ActiveControl as TListBox) = ListBox1) then
  begin
    ListBox1.TopIndex := ListBox1.TopIndex + Value;
    Handled := True;
  end;
end;

procedure TForm1.FormMouseWheelUp(Sender: TObject; Shift: TShiftState;
  MousePos: TPoint; var Handled: Boolean);
const
  Value = -1;
begin
  if (ActiveControl is TListBox) and
    ((ActiveControl as TListBox) = ListBox1) then
  begin
    ListBox1.TopIndex := ListBox1.TopIndex + Value;
    Handled := True;
  end;
end;

Valueの値を変えて、スクロールの移動量も変えたりするようにプログラムを修正することもできますね。

☆ListBoxのDrawItem No1

ListBoxにフォントを一覧表示するプログラムを作ってみました。 よくある自分自身のフォントでフォント名を表示させるものです。 しかしマウスをスクロールさせると表示がどうもおかしいです。
マウスを上に回転させても下に回転させても、アニメーションが上からの表示になっています。 しばらく使っていると目が回ってしまいます（笑）

いろいろと調べてみるとMicrosoftのページに、次のようなものがありました。
（2005年1月24日付になっているので、私だけが知らなかったのかも知れませんね）

BUG: ListBox コントロールは、 Windows 2000 または Windows XP で間違った方向にスクロールすることが表示されます。
（機械翻訳なので日本語が変ですね）
[引用]

現象
キーボードを使う、またはスクロール バーを使用する場合、スクロールするとき、
オーナー描画 ListBox コントロールが間違った方向の内容をスクロールすることが 
Microsoft Windows 2000 と Windows XP で表示されます。 
下でスクロールするとき、 smooth-scroll アニメーションが ListBox コントロールの
内容が上にスクロールされることが表示されるのを行います。 ListBox コントロール
が間違った方向にスクロールすることが表示されるものの、 smooth-scroll アニメ
ーションが完了したら、正しい位置にリストアイテムがあります。

回避策としては、アニメーションをさせないということなので、次のような処理をしました。

procedure TForm1.FormCreate(Sender: TObject);
begin
  SystemParametersInfo(SPI_SETLISTBOXSMOOTHSCROLLING, 0, nil, 0);
  GetFontName;
end;

Microsoft サポートオンライン
BUG: ListBox コントロールは、 Windows 2000 または Windows XP で間違った方向にスクロールすることが表示されます。