如何在同一行与其他控件一起显示列表文本? [英] How to display list text with other controls on same line?

问题描述

作为我自己的练习，我正在尝试从(引人入胜的)

用户在编辑框控件中写入待办事项(在划掉的购买牛奶"上方)，然后按 Enter.待办事项显示在下方.

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

我不在乎按钮、有图像或仅出现在 OnEnter 上.我不知道如何使用单选控件和按钮制作类似样式的(ListView?ComboBox?)控件.

我使用的是 Delphi VCL，但可以切换到 FMX.

解决方案

这里确实没有任何捷径:您只需要编写大量代码.Windows 操作系统不提供这样的功能.我将使用带有自定义 GDI 绘画和鼠标和键盘输入处理的空窗口从头开始实现.一点也不难，但确实需要很多代码.

那是很多字，没有代码.

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

unit ItemListBox;界面用途Windows、SysUtils、类型、UITypes、类、控件、图形、Generics.Defaults、泛型.集合、表单、消息、Direct2D、D2D1；类型TItem = 类严格的私人FCaption: TCaption;FChecked:布尔值；FTag: NativeInt;FOnChanged:TNotifyEvent；程序改变；过程 SetCaption(const Value: TCaption);过程 SetChecked(const Value: Boolean);民众属性 Caption:TCaption 读 FCaption 写 SetCaption；属性检查:布尔读取 FChecked 写入 SetChecked；属性标签:NativeInt 读 FTag 写 FTag；属性 OnChanged:TNotifyEvent 读 FOnChanged 写 FOnChanged；结尾;TPart = (ilbpText, ilbpCheckBox, ilbpClearButton);TItemListBox = 类(TCustomControl)严格的私人FItems:TObjectList;FItemHeight:整数；FCanvas:TDirect2DCanvas；FIndex:整数；FPart:TPart；FMouseDownIndex:整数；FMouseDownPart:TPart；FFocusIndex:整数；函数 GetItem(Index: Integer): TItem;函数 GetItemCount:整数；程序 ItemChanged(Sender: TObject);过程 DrawItem(索引:整数；项目:TItem)；过程DrawCheckBox(索引:整数；项目:TItem；热:布尔=假)；过程 DrawClearButton(Index: Integer; Visible: Boolean; Hot: Boolean = False);函数 ItemRect(Index: Integer): TRect;函数 TextRect(Index: Integer): TRect;函数 CheckBoxRect(Index: Integer): TRect;函数 ClearButtonRect(Index: Integer): TRect;程序创建设备资源；程序 HitTest(const P: TPoint; out Index: Integer; out Part: TPart);过程 StateChange(ANewIndex: Integer; ANewPart: TPart);函数画布宽度:整数；函数画布高度:整数；受保护程序油漆；覆盖；程序 WMPaint(var Message: TWMPaint);消息 WM_PAINT;过程 WMSize(var 消息:TWMSize)；消息 WM_SIZE;程序 WMEraseBkgnd(var Message: TWMEraseBkgnd);消息 WM_ERASEBKGND;程序 CreateWnd;覆盖；过程 MouseDown(Button: TMouseButton; Shift: TShiftState; X: Integer;Y:整数)；覆盖；过程鼠标移动(Shift:TShiftState；X:整数；Y:整数)；覆盖；过程 CMMouseLeave(var Message: TMessage);消息 CM_MOUSELEAVE;过程 MouseUp(Button: TMouseButton; Shift: TShiftState; X: Integer;Y:整数)；覆盖；过程 KeyDown(var Key: Word; Shift: TShiftState);覆盖；程序 WMGetDlgCode(var Message: TWMGetDlgCode);消息 WM_GETDLGCODE;程序 WMSetFocus(var Message: TWMSetFocus);消息 WM_SETFOCUS;程序 WMKillFocus(var Message: TWMKillFocus);消息 WM_KILLFOCUS;民众构造函数创建(AOwner:TComponent)；覆盖；析构函数销毁；覆盖；属性画布:TDirect2DCanvas 读取 FCanvas；函数 AddItem(const ACaption: string; AChecked: Boolean;ATag:NativeInt = 0):整数；过程移除项(AIndex:整数)；属性 Items[Index: Integer]: TItem 读取 GetItem；属性 ItemCount:整数读取 GetItemCount；发表属性对齐；属性 AlignWithMargins;属性锚；属性游标；属性字体；财产提示；属性弹出菜单；属性 TabOrder；属性 TabStop 默认为 True；结尾;程序注册；执行用途数学;程序注册；开始RegisterComponents('Rejbrand 2020', [TItemListBox]);结尾;功能规模(X:整数):整数；开始结果 := MulDiv(X, Screen.PixelsPerInch, 96);结尾;{ 项目 }过程 TItem.Changed;开始如果已分配(FOnChanged) 那么FOnChanged(自我)；结尾;过程 TItem.SetCaption(const Value: TCaption);开始如果 FCaption <>价值然后开始FCaption := 值；改变了；结尾;结尾;过程 TItem.SetChecked(const Value: Boolean);开始如果 FChecked <>价值然后开始FChecked := 值;改变了；结尾;结尾;{ TItemListBox }函数 TItemListBox.AddItem(const ACaption: string; AChecked: Boolean;ATag:NativeInt):整数；无功项目:TItem；开始项目 := TItem.Create;Item.Caption := ACaption;Item.Checked := AChecked;Item.OnChanged := ItemChanged;结果 := FItems.Add(Item);InvalidateRect(Handle, ItemRect(Result), True);结尾;函数 TItemListBox.ClearButtonRect(Index: Integer): TRect;开始结果 := Rect(CanvasWidth - 32, Index * FItemHeight, CanvasWidth,(索引 + 1) * FItemHeight);结尾;过程 TItemListBox.CMMouseLeave(var Message: TMessage);开始遗传;StateChange(-1, ilbpText);结尾;构造函数 TItemListBox.Create(AOwner: TComponent);开始遗传;FItems := TObjectList.Create;FItemHeight := 32;FIndex := -1;FMouseDownIndex := -1;FFocusIndex := -1;颜色:= clWindow；TabStop := 真;结尾;过程 TItemListBox.CreateDeviceResources;开始FreeAndNil(FCanvas);FCanvas := TDirect2DCanvas.Create(Handle);结尾;过程 TItemListBox.CreateWnd;开始遗传;创建设备资源；结尾;析构函数 TItemListBox.Destroy;开始FreeAndNil(FItems);FreeAndNil(FCanvas);遗传;结尾;过程 TItemListBox.DrawClearButton(Index: Integer; Visible: Boolean; Hot: Boolean);无功R: 矩形；开始如果不可见，则出口;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);结尾;程序 TItemListBox.DrawItem(Index: Integer; Item: TItem);无功R: 矩形；S:字符串；开始//背景Canvas.Brush.Color := clWindow;Canvas.Brush.Style := bsSolid;Canvas.Pen.Color := clWindowText;Canvas.Pen.Width := 1;Canvas.Pen.Style := psSolid;R := ItemRect(索引);Canvas.FillRect(R);//文本R := TextRect(索引);S := Item.Caption;Canvas.Font.Assign(字体);Canvas.Font.Color := IfThen(Item.Checked, clGrayText, clWindowText);如果 Item.Checked 那么Canvas.Font.Style := [fsStrikeOut]别的Canvas.Font.Style := [];Canvas.TextRect(R, S, [tfSingleLine, tfEndEllipsis, tfVerticalCenter]);//复选框DrawCheckBox(Index, Item, (FIndex = Index) and (FPart = ilbpCheckBox));//清除按钮DrawClearButton(Index, FIndex = Index, (FIndex = Index) and (FPart = ilbpClearButton));//焦点指示器如果 InRange(FFocusIndex, 0, FItems.Count - 1) 和 Focused then开始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);结尾;结尾;过程 TItemListBox.DrawCheckBox(Index: Integer; Item: TItem;热:布尔)；无功R: 矩形；开始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);如果 Assigned(Item) 和 Item.Checked 那么开始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);结尾;结尾;函数 TItemListBox.GetItem(Index: Integer): TItem;开始结果 := FItems[索引];结尾;函数 TItemListBox.GetItemCount:整数；开始结果:= FItems.Count;结尾;过程 TItemListBox.HitTest(const P: TPoint; out Index: Integer;出部分:TPart)；无功i:整数；问:T点；开始Q.X := MulDiv(P.X, 96, Screen.PixelsPerInch);Q.Y := MulDiv(P.Y, 96, Screen.PixelsPerInch);对于 i := 0 到 FItems.Count - 1 做如果 ItemRect(i).Contains(Q) 那么开始索引 := i;如果 CheckBoxRect(i).Contains(Q) 那么部分:= ilbpCheckBox否则如果 ClearButtonRect(i).Contains(Q) 那么部分:= ilbpClearButton别的部分:= ilbpText；出口;结尾;指数:= -1;部分:= ilbpText；结尾;过程 TItemListBox.ItemChanged(Sender: TObject);开始无效；结尾;函数 TItemListBox.ItemRect(Index: Integer): TRect;开始结果 := Rect(0, Index * FItemHeight, CanvasWidth, (Index + 1) * FItemHeight);结尾;过程 TItemListBox.KeyDown(var Key: Word; Shift: TShiftState);开始遗传;案例 Key ofVK_DOWN:如果 Succ(FFocusIndex) <= FItems.Count - 1 那么开始Inc(FFocusIndex);无效；结尾;VK_UP:如果 Pred(FFocusIndex) >= 0 那么开始十二月(FFocusIndex)；无效；结尾;VK_HOME:如果 FFocusIndex <>0 那么开始F焦点索引:= 0；无效；结尾;VK_END:如果 FFocusIndex <>FItems.Count - 1 然后开始FFocusIndex := FItems.Count - 1;无效；结尾;VK_SPACE:如果 InRange(FFocusIndex, 0, FItems.Count - 1) 那么FItems[FFocusIndex].Checked := 不是 FItems[FFocusIndex].Checked;VK_DELETE:如果 InRange(FFocusIndex, 0, FItems.Count - 1) 那么删除项目(FFocusIndex)；结尾;结尾;过程 TItemListBox.MouseDown(Button: TMouseButton; Shift: TShiftState; X,Y:整数)；开始遗传;如果 CanFocus 那么设置焦点；HitTest(Point(X, Y), FMouseDownIndex, FMouseDownPart);如果 FFocusIndex <>FMouseDownIndex 然后开始FFocusIndex := FMouseDownIndex;无效；结尾;结尾;过程 TItemListBox.MouseMove(Shift: TShiftState; X, Y: Integer);无功新索引:整数；新建零件:TPart；开始遗传;HitTest(Point(X, Y), NewIndex, NewPart);状态变化(新索引，新部分)；结尾;过程 TItemListBox.MouseUp(Button: TMouseButton; Shift: TShiftState; X,Y:整数)；无功索引:整数；零件:T零件；开始HitTest(Point(X, Y), Index, Part);if (Index <> -1) and (Index = FMouseDownIndex) and (Button = mbLeft) then开始如果 (Part = ilbpCheckBox) 和 (Part = FMouseDownPart) 那么FItems[Index].Checked := not FItems[Index].Checked否则如果 (Part = ilbpClearButton) 和 (Part = FMouseDownPart) 那么删除项目(索引)；结尾;结尾;过程 TItemListBox.Paint;无功i:整数；开始Canvas.RenderTarget.Clear(D2D1ColorF(clWhite));对于 i := 0 到 FItems.Count - 1 做DrawItem(i, FItems[i]);结尾;过程 TItemListBox.RemoveItem(AIndex: Integer);开始FItems.Delete(AIndex);FFocusIndex :=EnsureRange(FFocusIndex, 0, FItems.Count - 1);无效；结尾;过程 TItemListBox.StateChange(ANewIndex: Integer; ANewPart: TPart);无功OldIndex:整数；旧部分:TPart；开始OldIndex := FIndex;OldPart := FPart;FIndex := ANewIndex;FPart := ANewPart;如果 FIndex = OldIndex 那么开始如果 FPart <>旧部分然后开始如果 ilbpCheckBox 在 [FPart, OldPart] 然后InvalidateRect(Handle, CheckBoxRect(FIndex), True);如果 ilbpClearButton 在 [FPart, OldPart] 然后InvalidateRect(Handle, ClearButtonRect(FIndex), True);结尾;结尾别的开始InvalidateRect(Handle, ItemRect(OldIndex), True);InvalidateRect(Handle, ItemRect(FIndex), True);结尾;结尾;函数 TItemListBox.CanvasHeight: Integer;开始结果 := MulDiv(ClientHeight, 96, Screen.PixelsPerInch);结尾;函数 TItemListBox.CanvasWidth: Integer;开始结果 := MulDiv(ClientWidth, 96, Screen.PixelsPerInch);结尾;函数 TItemListBox.CheckBoxRect(Index: Integer): TRect;开始结果 := Rect(0, Index * FItemHeight, 32, (Index + 1) * FItemHeight);结尾;函数 TItemListBox.TextRect(Index: Integer): TRect;开始结果 := Rect(40, Index * FItemHeight, CanvasWidth - 40,(索引 + 1) * FItemHeight);结尾;过程 TItemListBox.WMEraseBkgnd(var Message: TWMEraseBkgnd);开始消息.结果:= 1;结尾;过程 TItemListBox.WMGetDlgCode(var Message: TWMGetDlgCode);开始遗传;Message.Result := Message.Result 或 DLGC_WANTARROWS;结尾;过程 TItemListBox.WMKillFocus(var Message: TWMKillFocus);开始遗传;无效；结尾;过程 TItemListBox.WMPaint(var Message: TWMPaint);无功油漆结构:TPaintStruct；资源:HRESULT；开始开始绘画(句柄，PaintStruct)；尝试如果已分配(FCanvas) 那么开始FCanvas.BeginDraw;尝试画;最后res := FCanvas.RenderTarget.EndDraw;如果 res = D2DERR_RECREATE_TARGET 那么创建设备资源；结尾;结尾;最后EndPaint(手柄，PaintStruct)；结尾;结尾;过程 TItemListBox.WMSetFocus(var Message: TWMSetFocus);开始遗传;无效；结尾;过程 TItemListBox.WMSize(var Message: TWMSize);无功S:TD2DSizeU；开始如果已分配(FCanvas) 那么开始S := D2D1SizeU(ClientWidth, ClientHeight);ID2D1HwndRenderTarget(FCanvas.RenderTarget).Resize(S);结尾;无效；遗传;结尾;结尾.

示例(顶部有一个简单的 TEdit):

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

更新:我添加了高 DPI 支持和键盘界面(向上、向下、主页、结束、空格、删除):

As an exercise for myself, I'm trying to recreate the To-Do app from the (fascinating) todomvc.com web site. The UI looks like this:

A user writes a To-Do item in an Edit box control (above the crossed out "buy milk") and presses Enter. To-Do items appear below.

As you can see, each line includes a stylized radio control, the text, and a button with an image (red x). The button appears when a user hovers the cursor inside the line.

I don't care about the button, having an image, or appearing only upon OnEnter. I can't figure out how to make a similarly styled (ListView? ComboBox?) control with a radio control and button.

I'm using Delphi VCL, but could switch to FMX.

解决方案

There really isn't any shortcut here: you simply need to write quite a lot of code. The Windows OS doesn't provide anything like this. I would implement from scratch using an empty window with custom GDI painting and mouse and keyboard input processing. It's not difficult at all, but it does require quite a lot of code.

That was a lot of words and no code.

As a remedy, here is a very quick demonstration control based on Direct2D (because I realised I really do need anti aliasing):

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.

Example (with a simple TEdit at the top):

But please notice that this is not a finished control; it's merely a very primitive sketch or prototype. It is not fully tested. In addition, a real control would have scrolling support and a keyboard interface. Since it is very late in Sweden right now, I don't really have time to add that at the moment.

Update: I added high-DPI support and a keyboard interface (up, down, home, end, space, delete):

这篇关于如何在同一行与其他控件一起显示列表文本?的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！