如何在同一行显示列表文本和其他控件？

Question

作为我自己的练习，我正在尝试从（迷人的）todomvc.com web site 重新创建待办事项应用程序。 UI 看起来像这样：

用户在编辑框控件（在划掉的“购买牛奶”上方）中写入待办事项，然后按 Enter。待办事项显示在下方。

如您所见，每一行都包含一个程式化的单选控件、文本和一个带有图像的按钮（红色 x）。当用户将光标悬停在行内时，该按钮就会出现。

我不关心按钮、有图像或只出现在 OnEnter 上。我不知道如何使用单选控件和按钮制作类似样式（ListView？ComboBox？）的控件。

我正在使用 Delphi VCL，但可以切换到 FMX。

Answer 1

这里确实没有任何捷径：您只需要编写大量代码即可。 Windows OS 没有提供这样的东西。我会使用带有自定义 GDI 绘画和鼠标和键盘输入处理的空 window 从头开始实施。一点都不难，但确实需要相当多的代码。

那是很多话，没有代码。

作为补救措施，这里有一个非常快速的基于 Direct2D 的演示控件（因为我意识到我确实需要抗锯齿）：

unit ItemListBox;

interface

uses
  Windows, SysUtils, Types, UITypes, Classes, Controls, Graphics, Generics.Defaults,
  Generics.Collections, Forms, Messages, Direct2D, D2D1;

type
  TItem = class
  strict private
    FCaption: TCaption;
    FChecked: Boolean;
    FTag: NativeInt;
    FOnChanged: TNotifyEvent;
    procedure Changed;
    procedure SetCaption(const Value: TCaption);
    procedure SetChecked(const Value: Boolean);
  public
    property Caption: TCaption read FCaption write SetCaption;
    property Checked: Boolean read FChecked write SetChecked;
    property Tag: NativeInt read FTag write FTag;
    property OnChanged: TNotifyEvent read FOnChanged write FOnChanged;
  end;

  TPart = (ilbpText, ilbpCheckBox, ilbpClearButton);

  TItemListBox = class(TCustomControl)
  strict private
    FItems: TObjectList<TItem>;
    FItemHeight: Integer;
    FCanvas: TDirect2DCanvas;
    FIndex: Integer;
    FPart: TPart;
    FMouseDownIndex: Integer;
    FMouseDownPart: TPart;
    FFocusIndex: Integer;
    function GetItem(Index: Integer): TItem;
    function GetItemCount: Integer;
    procedure ItemChanged(Sender: TObject);
    procedure DrawItem(Index: Integer; Item: TItem);
    procedure DrawCheckBox(Index: Integer; Item: TItem; Hot: Boolean = False);
    procedure DrawClearButton(Index: Integer; Visible: Boolean; Hot: Boolean = False);
    function ItemRect(Index: Integer): TRect;
    function TextRect(Index: Integer): TRect;
    function CheckBoxRect(Index: Integer): TRect;
    function ClearButtonRect(Index: Integer): TRect;
    procedure CreateDeviceResources;
    procedure HitTest(const P: TPoint; out Index: Integer; out Part: TPart);
    procedure StateChange(ANewIndex: Integer; ANewPart: TPart);
    function CanvasWidth: Integer;
    function CanvasHeight: Integer;
  protected
    procedure Paint; override;
    procedure WMPaint(var Message: TWMPaint); message WM_PAINT;
    procedure WMSize(var Message: TWMSize); message WM_SIZE;
    procedure WMEraseBkgnd(var Message: TWMEraseBkgnd); message WM_ERASEBKGND;
    procedure CreateWnd; override;
    procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X: Integer;
      Y: Integer); override;
    procedure MouseMove(Shift: TShiftState; X: Integer; Y: Integer); override;
    procedure CMMouseLeave(var Message: TMessage); message CM_MOUSELEAVE;
    procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X: Integer;
      Y: Integer); override;
    procedure KeyDown(var Key: Word; Shift: TShiftState); override;
    procedure WMGetDlgCode(var Message: TWMGetDlgCode); message WM_GETDLGCODE;
    procedure WMSetFocus(var Message: TWMSetFocus); message WM_SETFOCUS;
    procedure WMKillFocus(var Message: TWMKillFocus); message WM_KILLFOCUS;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    property Canvas: TDirect2DCanvas read FCanvas;
    function AddItem(const ACaption: string; AChecked: Boolean;
      ATag: NativeInt = 0): Integer;
    procedure RemoveItem(AIndex: Integer);
    property Items[Index: Integer]: TItem read GetItem;
    property ItemCount: Integer read GetItemCount;
  published
    property Align;
    property AlignWithMargins;
    property Anchors;
    property Cursor;
    property Font;
    property Hint;
    property PopupMenu;
    property TabOrder;
    property TabStop default True;
  end;

procedure Register;

implementation

uses
  Math;

procedure Register;
begin
  RegisterComponents('Rejbrand 2020', [TItemListBox]);
end;

function Scale(X: Integer): Integer;
begin
  Result := MulDiv(X, Screen.PixelsPerInch, 96);
end;

{ TItem }

procedure TItem.Changed;
begin
  if Assigned(FOnChanged) then
    FOnChanged(Self);
end;

procedure TItem.SetCaption(const Value: TCaption);
begin
  if FCaption <> Value then
  begin
    FCaption := Value;
    Changed;
  end;
end;

procedure TItem.SetChecked(const Value: Boolean);
begin
  if FChecked <> Value then
  begin
    FChecked := Value;
    Changed;
  end;
end;

{ TItemListBox }

function TItemListBox.AddItem(const ACaption: string; AChecked: Boolean;
  ATag: NativeInt): Integer;
var
  Item: TItem;
begin
  Item := TItem.Create;
  Item.Caption := ACaption;
  Item.Checked := AChecked;
  Item.OnChanged := ItemChanged;
  Result := FItems.Add(Item);
  InvalidateRect(Handle, ItemRect(Result), True);
end;

function TItemListBox.ClearButtonRect(Index: Integer): TRect;
begin
  Result := Rect(CanvasWidth - 32, Index * FItemHeight, CanvasWidth,
    (Index + 1) * FItemHeight);
end;

procedure TItemListBox.CMMouseLeave(var Message: TMessage);
begin
  inherited;
  StateChange(-1, ilbpText);
end;

constructor TItemListBox.Create(AOwner: TComponent);
begin
  inherited;
  FItems := TObjectList<TItem>.Create;
  FItemHeight := 32;
  FIndex := -1;
  FMouseDownIndex := -1;
  FFocusIndex := -1;
  Color := clWindow;
  TabStop := True;
end;

procedure TItemListBox.CreateDeviceResources;
begin
  FreeAndNil(FCanvas);
  FCanvas := TDirect2DCanvas.Create(Handle);
end;

procedure TItemListBox.CreateWnd;
begin
  inherited;
  CreateDeviceResources;
end;

destructor TItemListBox.Destroy;
begin
  FreeAndNil(FItems);
  FreeAndNil(FCanvas);
  inherited;
end;

procedure TItemListBox.DrawClearButton(Index: Integer; Visible: Boolean; Hot: Boolean);
var
  R: TRect;
begin
  if not Visible then
    Exit;
  R := ClearButtonRect(Index);
  InflateRect(R, -7, -7);
  Canvas.Pen.Color := IfThen(Hot, clRed, clMaroon);
  Canvas.Pen.Width := 2;
  Canvas.MoveTo(R.Left, R.Top);
  Canvas.LineTo(R.Right, R.Bottom);
  Canvas.MoveTo(R.Right, R.Top);
  Canvas.LineTo(R.Left, R.Bottom);
end;

procedure TItemListBox.DrawItem(Index: Integer; Item: TItem);
var
  R: TRect;
  S: string;
begin

  // Background
  Canvas.Brush.Color := clWindow;
  Canvas.Brush.Style := bsSolid;
  Canvas.Pen.Color := clWindowText;
  Canvas.Pen.Width := 1;
  Canvas.Pen.Style := psSolid;
  R := ItemRect(Index);
  Canvas.FillRect(R);

  // Text
  R := TextRect(Index);
  S := Item.Caption;
  Canvas.Font.Assign(Font);
  Canvas.Font.Color := IfThen(Item.Checked, clGrayText, clWindowText);
  if Item.Checked then
    Canvas.Font.Style := [fsStrikeOut]
  else
    Canvas.Font.Style := [];
  Canvas.TextRect(R, S, [tfSingleLine, tfEndEllipsis, tfVerticalCenter]);

  // Check box
  DrawCheckBox(Index, Item, (FIndex = Index) and (FPart = ilbpCheckBox));

  // Clear button
  DrawClearButton(Index, FIndex = Index, (FIndex = Index) and (FPart = ilbpClearButton));

  // Focus indicator
  if InRange(FFocusIndex, 0, FItems.Count - 1) and Focused then
  begin
    Canvas.Pen.Color := clSilver;
    Canvas.Pen.Width := 1;
    Canvas.Pen.Style := psSolid;
    Canvas.Brush.Style := bsClear;
    R := TextRect(FFocusIndex);
    InflateRect(R, 0, -2);
    Canvas.Rectangle(R);
  end;

end;

procedure TItemListBox.DrawCheckBox(Index: Integer; Item: TItem;
  Hot: Boolean);
var
  R: TRect;
begin
  R := CheckBoxRect(Index);
  InflateRect(R, -5, -5);
  Canvas.Pen.Color := clSilver;
  Canvas.Pen.Width := 1;
  Canvas.Brush.Color := IfThen(Hot, clSilver, clWhite);
  Canvas.Ellipse(R);
  if Assigned(Item) and Item.Checked then
  begin
    Canvas.Pen.Color := clGreen;
    Canvas.Pen.Width := 2;
    Canvas.MoveTo(R.Left + R.Width div 5, R.Bottom - R.Height div 2);
    Canvas.LineTo(R.Left + Round(R.Width / 2.5), R.Bottom - Round(R.Height / 3.8));
    Canvas.LineTo(R.Right - Round(R.Width / 4.5), R.Top + R.Height div 5);
  end;
end;

function TItemListBox.GetItem(Index: Integer): TItem;
begin
  Result := FItems[Index];
end;

function TItemListBox.GetItemCount: Integer;
begin
  Result := FItems.Count;
end;

procedure TItemListBox.HitTest(const P: TPoint; out Index: Integer;
  out Part: TPart);
var
  i: Integer;
  Q: TPoint;
begin
  Q.X := MulDiv(P.X, 96, Screen.PixelsPerInch);
  Q.Y := MulDiv(P.Y, 96, Screen.PixelsPerInch);
  for i := 0 to FItems.Count - 1 do
    if ItemRect(i).Contains(Q) then
    begin
      Index := i;
      if CheckBoxRect(i).Contains(Q) then
        Part := ilbpCheckBox
      else if ClearButtonRect(i).Contains(Q) then
        Part := ilbpClearButton
      else
        Part := ilbpText;
      Exit;
    end;
  Index := -1;
  Part := ilbpText;
end;

procedure TItemListBox.ItemChanged(Sender: TObject);
begin
  Invalidate;
end;

function TItemListBox.ItemRect(Index: Integer): TRect;
begin
  Result := Rect(0, Index * FItemHeight, CanvasWidth, (Index + 1) * FItemHeight);
end;

procedure TItemListBox.KeyDown(var Key: Word; Shift: TShiftState);
begin
  inherited;
  case Key of
    VK_DOWN:
      if Succ(FFocusIndex) <= FItems.Count - 1 then
      begin
        Inc(FFocusIndex);
        Invalidate;
      end;
    VK_UP:
      if Pred(FFocusIndex) >= 0 then
      begin
        Dec(FFocusIndex);
        Invalidate;
      end;
    VK_HOME:
      if FFocusIndex <> 0 then
      begin
        FFocusIndex := 0;
        Invalidate;
      end;
    VK_END:
      if FFocusIndex <> FItems.Count - 1 then
      begin
        FFocusIndex := FItems.Count - 1;
        Invalidate;
      end;
    VK_SPACE:
      if InRange(FFocusIndex, 0, FItems.Count - 1) then
        FItems[FFocusIndex].Checked := not FItems[FFocusIndex].Checked;
    VK_DELETE:
      if InRange(FFocusIndex, 0, FItems.Count - 1) then
        RemoveItem(FFocusIndex);
  end;
end;

procedure TItemListBox.MouseDown(Button: TMouseButton; Shift: TShiftState; X,
  Y: Integer);
begin
  inherited;
  if CanFocus then
    SetFocus;
  HitTest(Point(X, Y), FMouseDownIndex, FMouseDownPart);
  if FFocusIndex <> FMouseDownIndex then
  begin
    FFocusIndex := FMouseDownIndex;
    Invalidate;
  end;
end;

procedure TItemListBox.MouseMove(Shift: TShiftState; X, Y: Integer);
var
  NewIndex: Integer;
  NewPart: TPart;
begin
  inherited;
  HitTest(Point(X, Y), NewIndex, NewPart);
  StateChange(NewIndex, NewPart);
end;

procedure TItemListBox.MouseUp(Button: TMouseButton; Shift: TShiftState; X,
  Y: Integer);
var
  Index: Integer;
  Part: TPart;
begin
  HitTest(Point(X, Y), Index, Part);
  if (Index <> -1) and (Index = FMouseDownIndex) and (Button = mbLeft) then
  begin
    if (Part = ilbpCheckBox) and (Part = FMouseDownPart) then
      FItems[Index].Checked := not FItems[Index].Checked
    else if (Part = ilbpClearButton) and (Part = FMouseDownPart) then
      RemoveItem(Index);
  end;
end;

procedure TItemListBox.Paint;
var
  i: Integer;
begin
  Canvas.RenderTarget.Clear(D2D1ColorF(clWhite));
  for i := 0 to FItems.Count - 1 do
    DrawItem(i, FItems[i]);
end;

procedure TItemListBox.RemoveItem(AIndex: Integer);
begin
  FItems.Delete(AIndex);
  FFocusIndex := EnsureRange(FFocusIndex, 0, FItems.Count - 1);
  Invalidate;
end;

procedure TItemListBox.StateChange(ANewIndex: Integer; ANewPart: TPart);
var
  OldIndex: Integer;
  OldPart: TPart;
begin
  OldIndex := FIndex;
  OldPart := FPart;
  FIndex := ANewIndex;
  FPart := ANewPart;
  if FIndex = OldIndex then
  begin
    if FPart <> OldPart then
    begin
      if ilbpCheckBox in [FPart, OldPart] then
        InvalidateRect(Handle, CheckBoxRect(FIndex), True);
      if ilbpClearButton in [FPart, OldPart] then
        InvalidateRect(Handle, ClearButtonRect(FIndex), True);
    end;
  end
  else
  begin
    InvalidateRect(Handle, ItemRect(OldIndex), True);
    InvalidateRect(Handle, ItemRect(FIndex), True);
  end;
end;

function TItemListBox.CanvasHeight: Integer;
begin
  Result := MulDiv(ClientHeight, 96, Screen.PixelsPerInch);
end;

function TItemListBox.CanvasWidth: Integer;
begin
  Result := MulDiv(ClientWidth, 96, Screen.PixelsPerInch);
end;

function TItemListBox.CheckBoxRect(Index: Integer): TRect;
begin
  Result := Rect(0, Index * FItemHeight, 32, (Index + 1) * FItemHeight);
end;

function TItemListBox.TextRect(Index: Integer): TRect;
begin
  Result := Rect(40, Index * FItemHeight, CanvasWidth - 40,
    (Index + 1) * FItemHeight);
end;

procedure TItemListBox.WMEraseBkgnd(var Message: TWMEraseBkgnd);
begin
  Message.Result := 1;
end;

procedure TItemListBox.WMGetDlgCode(var Message: TWMGetDlgCode);
begin
  inherited;
  Message.Result := Message.Result or DLGC_WANTARROWS;
end;

procedure TItemListBox.WMKillFocus(var Message: TWMKillFocus);
begin
  inherited;
  Invalidate;
end;

procedure TItemListBox.WMPaint(var Message: TWMPaint);
var
  PaintStruct: TPaintStruct;
  res: HRESULT;
begin
  BeginPaint(Handle, PaintStruct);
  try
    if Assigned(FCanvas) then
    begin
      FCanvas.BeginDraw;
      try
        Paint;
      finally
        res := FCanvas.RenderTarget.EndDraw;
        if res = D2DERR_RECREATE_TARGET then
          CreateDeviceResources;
      end;
    end;
  finally
    EndPaint(Handle, PaintStruct);
  end;
end;

procedure TItemListBox.WMSetFocus(var Message: TWMSetFocus);
begin
  inherited;
  Invalidate;
end;

procedure TItemListBox.WMSize(var Message: TWMSize);
var
  S: TD2DSizeU;
begin
  if Assigned(FCanvas) then
  begin
    S := D2D1SizeU(ClientWidth, ClientHeight);
    ID2D1HwndRenderTarget(FCanvas.RenderTarget).Resize(S);
  end;
  Invalidate;
  inherited;
end;

end.

示例（顶部有一个简单的 TEdit）：

但请注意，这是不是完成的控件；它只是一个非常原始的草图或原型。它没有经过全面测试。此外，真正的控件将具有滚动支持和键盘界面。由于现在在瑞典已经很晚了，我现在真的没有时间补充。

更新： 我添加了高 DPI 支持和键盘界面（向上、向下、主页、结束、space、删除）：

如何在同一行显示列表文本和其他控件？

How to display list text with other controls on same line?

user-interface

delphi

delphi-10.3-rio