Блог

В качестве упражнения для себя я пытаюсь воссоздать приложение To-Do из (увлекательного) todomvc.com веб-сайт. Пользовательский интерфейс выглядит следующим образом:

Пользователь вводит элемент To-Do в поле редактирования (над зачеркнутым «купить молоко») и нажимаетEnter. Ниже отображаются элементы задач.

Как вы можете видеть, каждая строка содержит стилизованный элемент управления, текст и кнопку с изображением (красный крестик). Кнопка появляется, когда пользователь наводит курсор внутри строки.

Меня не волнует кнопка, имеющая изображение или появляющаяся только после OnEnter . Я не могу понять, как создать аналогичный стиль (ListView? ComboBox?) управление с помощью радиоуправления и кнопки.

Я использую Delphi VCL, но могу переключиться на FMX.

Здесь действительно нет никакого ярлыка: вам просто нужно написать довольно много кода. ОС Windows не предоставляет ничего подобного. Я бы реализовал с нуля, используя пустое окно с пользовательским отображением GDI и обработкой ввода с помощью мыши и клавиатуры. Это совсем не сложно, но требует довольно много кода.

Это было много слов и никакого кода.

В качестве решения проблемы, вот очень быстрый демонстрационный элемент управления на основе 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 вверху):

Но, пожалуйста, обратите внимание, что это не готовый элемент управления; это всего лишь очень примитивный эскиз или прототип. Он не полностью протестирован. Кроме того, реальный элемент управления будет иметь поддержку прокрутки и интерфейс клавиатуры. Поскольку в Швеции сейчас очень поздно, у меня сейчас нет времени добавлять это.

Обновление: я добавил поддержку высокого разрешения и интерфейс клавиатуры (вверх, вниз, домой, конец, пробел, удалить):