如何在所有者绘制的列表框中启用具有可变高度项的逻辑滚动条？

Question

最近，我遇到了以下问题：具有样式lbOwnerDrawVariable且仅包含一个元素的给定列表框不显示垂直滚动条，即使需要一个也是如此。文本被截断。如何启用滚动条？文字高度由DrawText(..)和DT_CALCRECT衡量，并返回合理的值，但不会显示滚动条。

示例截图：

这是一个小例子：

unit Unit1;

interface

uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants,
  System.Classes, System.StrUtils, Vcl.Graphics,
  Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls;

type

  TOwnerDrawnListboxItem = class
    AText: string;
  end;

  TOwnerDrawnListbox = class(TListbox)
  protected
    procedure Resize; override;
    procedure DrawItem(Index: Integer; DisplayRect: TRect; State: TOwnerDrawState); override;
    procedure MeasureItem(Index: Integer; var Height: Integer); override;
  const
    TEXT_FORMAT = DT_LEFT or DT_TOP or DT_NOPREFIX;
  end;

  TForm1 = class(TForm)
    procedure FormCreate(Sender: TObject);
  private
    FBox: TOwnerDrawnListbox;
    FData: TOwnerDrawnListboxItem;
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.FormCreate(Sender: TObject);
var
  I: Integer;
begin
  Width := 250;
  Height := 100;

  FData := TOwnerDrawnListboxItem.Create();
  for I := 10 to 30 do
    FData.AText := FData.AText + DupeString(I.ToString(), 80) + sLinebreak;

  FBox := TOwnerDrawnListbox.Create(Self);
  FBox.Parent := Self;
  FBox.Align := alClient;
  FBox.Style := lbOwnerDrawVariable;
  FBox.Items.AddObject('-', FData);
  FBox.Resize;
end;

procedure TOwnerDrawnListbox.DrawItem(Index: Integer; DisplayRect: TRect; State: TOwnerDrawState);
var
  LData: TOwnerDrawnListboxItem;
  LTextRect: TRect;
begin
  if (Index >= count) or (Items.Objects[Index] = nil) then
    Exit;

  LData := Items.Objects[Index] as TOwnerDrawnListboxItem;
  LTextRect := DisplayRect;
  Canvas.Font.Color := clBlack;
  Canvas.Brush.Color := clMoneygreen;
  Canvas.FillRect(DisplayRect);
  InflateRect(LTextRect, - 2, - 2);
  OffsetRect(LTextRect, 2, 2);
  DrawText(Canvas.Handle, PChar(LData.AText), - 1, LTextRect, TEXT_FORMAT);
end;

procedure TOwnerDrawnListbox.MeasureItem(Index: Integer; var Height: Integer);
var
  LTextRect: TRect;
  LLineHeight: Integer;
  LScrollWidth: Integer;
  LPadding: Integer;
  LData: TOwnerDrawnListboxItem;
  LHeight: Integer;
begin
  if (Index >= count) or (Items.Objects[Index] = nil) then
  begin
    Height := 1;
    Exit;
  end;

  LData := Items.Objects[Index] as TOwnerDrawnListboxItem;
  LLineHeight := Canvas.TextExtent('Gg').cy;
  LScrollWidth := GetSystemMetrics(SM_CXVSCROLL);
  LPadding := 4;
  LTextRect := Rect(0, 0, ClientWidth - LPadding - LScrollWidth, LLineHeight);
  LHeight := DrawText(Canvas.Handle, PChar(LData.AText), - 1, LTextRect, TEXT_FORMAT or DT_CALCRECT);
  Height := LHeight + LPadding;
end;

procedure TOwnerDrawnListbox.Resize;
var
  I: Integer;
  NewHeight: Integer;
begin
  for I := 0 to Pred(Items.count) do
  begin
    MeasureItem(I, NewHeight);
    SendMessage(Self.Handle, LB_SETITEMHEIGHT, I, NewHeight);
  end;

  inherited;

  Repaint;
end;

end.