ewsdr/FlatListBox.pas

unit FlatListBox;

{ Custom list box with canvas rendering.
  Use instead of TListBox where native widgetset styling is undesirable. }

{$mode objfpc}{$H+}

interface

uses
  Classes, SysUtils, Controls, Graphics, Forms, LCLType, LMessages, Types,
  Math, AppTheme;

type
  TFlatListBox = class(TCustomControl)
  private
    FItems: TStringList;
    FItemIndex: Integer;
    FHotIndex: Integer;
    FTopIndex: Integer;
    FMouseDownIndex: Integer;
    FClrOuterBG: TColor;
    FClrBG: TColor;
    FClrBGHot: TColor;
    FClrBorder: TColor;
    FClrText: TColor;
    FClrTextDim: TColor;
    FClrSelBG: TColor;
    FClrSelText: TColor;
    FClrScroll: TColor;
    function DpiScale(V: Integer): Integer;
    function ItemHeight: Integer;
    function VisibleCount: Integer;
    function ItemAt(Y: Integer): Integer;
    procedure ItemsChanged(Sender: TObject);
    procedure SetItemIndex(V: Integer);
    procedure SetTopIndex(V: Integer);
    procedure EnsureItemVisible(Idx: Integer);
    procedure CMTextChanged(var Msg: TLMessage); message CM_TEXTCHANGED;
  protected
    procedure Paint; override;
    procedure MouseEnter; override;
    procedure MouseLeave; override;
    procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
      X, Y: Integer); override;
    procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
    procedure MouseUp(Button: TMouseButton; Shift: TShiftState;
      X, Y: Integer); override;
    procedure KeyDown(var Key: Word; Shift: TShiftState); override;
    function DoMouseWheelUp(Shift: TShiftState; MousePos: TPoint): Boolean; override;
    function DoMouseWheelDown(Shift: TShiftState; MousePos: TPoint): Boolean; override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure SetAppTheme(const T: TAppTheme);

    property Items: TStringList read FItems;
    property ItemIndex: Integer read FItemIndex write SetItemIndex;
    property TopIndex: Integer read FTopIndex write SetTopIndex;
    property Align;
    property Anchors;
    property Enabled;
    property Font;
    property ParentShowHint;
    property PopupMenu;
    property ShowHint;
    property TabOrder;
    property TabStop;
    property Tag;
    property Visible;
    property OnClick;
    property OnDblClick;
  end;

implementation

const
  BASE_ITEM_H = 22;
  BASE_PAD_X = 8;
  BASE_SCROLL_W = 3;

constructor TFlatListBox.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  ControlStyle := ControlStyle + [csOpaque, csCaptureMouse, csClickEvents, csDoubleClicks];
  FItems := TStringList.Create;
  FItems.OnChange := @ItemsChanged;
  FItemIndex := -1;
  FHotIndex := -1;
  FTopIndex := 0;
  FMouseDownIndex := -1;
  Width := 180;
  Height := 140;
  TabStop := True;
  Cursor := crDefault;

  Font.Name := 'Courier New';
  Font.Size := 8;

  FClrOuterBG := TColor($00181818);
  FClrBG := TColor($00101010);
  FClrBGHot := TColor($000C3010);
  FClrBorder := TColor($00303030);
  FClrText := TColor($00CCCCCC);
  FClrTextDim := TColor($00666666);
  FClrSelBG := TColor($00183618);
  FClrSelText := TColor($0000FF88);
  FClrScroll := TColor($00387838);
end;

destructor TFlatListBox.Destroy;
begin
  FItems.Free;
  inherited Destroy;
end;

function TFlatListBox.DpiScale(V: Integer): Integer;
begin
  Result := MulDiv(V, Screen.PixelsPerInch, 96);
  if (V > 0) and (Result < 1) then
    Result := 1;
end;

function TFlatListBox.ItemHeight: Integer;
begin
  Canvas.Font.Assign(Font);
  Result := DpiScale(BASE_ITEM_H);
  if Result < Canvas.TextHeight('Ag') + DpiScale(7) then
    Result := Canvas.TextHeight('Ag') + DpiScale(7);
end;

function TFlatListBox.VisibleCount: Integer;
begin
  Result := Max(1, (Height - DpiScale(2)) div ItemHeight);
end;

function TFlatListBox.ItemAt(Y: Integer): Integer;
begin
  Result := FTopIndex + (Y - DpiScale(1)) div ItemHeight;
  if (Result < 0) or (Result >= FItems.Count) then
    Result := -1;
end;

procedure TFlatListBox.SetAppTheme(const T: TAppTheme);
begin
  FClrOuterBG := T.Panel;
  FClrBG := T.BG;
  FClrBGHot := T.BtnActive;
  FClrBorder := T.Border;
  FClrText := T.Text;
  FClrTextDim := T.TextDim;
  FClrSelBG := T.SliderTrackFill;
  FClrSelText := T.BtnTextActive;
  FClrScroll := T.BtnBorderActive;
  Font.Color := T.Text;
  Invalidate;
end;

procedure TFlatListBox.ItemsChanged(Sender: TObject);
begin
  if FItems.Count = 0 then
    FItemIndex := -1
  else if FItemIndex >= FItems.Count then
    FItemIndex := FItems.Count - 1;
  if FHotIndex >= FItems.Count then
    FHotIndex := -1;
  SetTopIndex(FTopIndex);
  Invalidate;
end;

procedure TFlatListBox.SetItemIndex(V: Integer);
begin
  V := EnsureRange(V, -1, FItems.Count - 1);
  if FItemIndex = V then
  begin
    EnsureItemVisible(FItemIndex);
    Exit;
  end;
  FItemIndex := V;
  EnsureItemVisible(FItemIndex);
  Invalidate;
end;

procedure TFlatListBox.SetTopIndex(V: Integer);
begin
  V := EnsureRange(V, 0, Max(0, FItems.Count - VisibleCount));
  if FTopIndex = V then Exit;
  FTopIndex := V;
  Invalidate;
end;

procedure TFlatListBox.EnsureItemVisible(Idx: Integer);
var
  VC: Integer;
begin
  if Idx < 0 then Exit;
  VC := VisibleCount;
  if Idx < FTopIndex then
    SetTopIndex(Idx)
  else if Idx >= FTopIndex + VC then
    SetTopIndex(Idx - VC + 1);
end;

procedure TFlatListBox.CMTextChanged(var Msg: TLMessage);
begin
  Invalidate;
end;

procedure TFlatListBox.Paint;
var
  i, ItemIdx, IH, Y, TextY, Pad, ScrollW, ThumbTop, ThumbH: Integer;
  R, TextR: TRect;
begin
  Canvas.Brush.Color := FClrOuterBG;
  Canvas.Brush.Style := bsSolid;
  Canvas.Pen.Style := psClear;
  Canvas.FillRect(ClientRect);

  Canvas.Brush.Color := FClrBG;
  Canvas.Brush.Style := bsSolid;
  Canvas.Pen.Color := FClrBorder;
  Canvas.Pen.Style := psSolid;
  Canvas.Pen.Width := 1;
  Canvas.Rectangle(0, 0, Width, Height);

  Canvas.Font.Assign(Font);
  IH := ItemHeight;
  Pad := DpiScale(BASE_PAD_X);
  ScrollW := DpiScale(BASE_SCROLL_W);
  for i := 0 to VisibleCount - 1 do
  begin
    ItemIdx := FTopIndex + i;
    if ItemIdx >= FItems.Count then Break;
    Y := DpiScale(1) + i * IH;
    R := Rect(DpiScale(1), Y, Width - DpiScale(1), Y + IH);
    if ItemIdx = FItemIndex then
    begin
      Canvas.Brush.Color := FClrSelBG;
      Canvas.Font.Color := FClrSelText;
    end
    else if (ItemIdx = FHotIndex) and Enabled then
    begin
      Canvas.Brush.Color := FClrBGHot;
      Canvas.Font.Color := FClrText;
    end
    else
    begin
      Canvas.Brush.Color := FClrBG;
      if Enabled then
        Canvas.Font.Color := FClrText
      else
        Canvas.Font.Color := FClrTextDim;
    end;
    Canvas.Pen.Style := psClear;
    Canvas.Brush.Style := bsSolid;
    Canvas.FillRect(R);
    Canvas.Brush.Style := bsClear;
    TextY := Y + (IH - Canvas.TextHeight('Ag')) div 2;
    TextR := Rect(Pad, Y, Width - Pad - ScrollW, Y + IH);
    Canvas.TextRect(TextR, TextR.Left, TextY, FItems[ItemIdx]);
  end;

  if FItems.Count > VisibleCount then
  begin
    ThumbH := Max(DpiScale(16), MulDiv(Height - DpiScale(4), VisibleCount, FItems.Count));
    ThumbTop := DpiScale(2) + MulDiv(Height - DpiScale(4) - ThumbH,
      FTopIndex, Max(1, FItems.Count - VisibleCount));
    Canvas.Brush.Color := FClrScroll;
    Canvas.Brush.Style := bsSolid;
    Canvas.Pen.Style := psClear;
    Canvas.FillRect(Rect(Width - DpiScale(5), ThumbTop, Width - DpiScale(2), ThumbTop + ThumbH));
  end;
end;

procedure TFlatListBox.MouseEnter;
begin
  inherited;
  Invalidate;
end;

procedure TFlatListBox.MouseLeave;
begin
  inherited;
  FHotIndex := -1;
  Invalidate;
end;

procedure TFlatListBox.MouseDown(Button: TMouseButton; Shift: TShiftState;
  X, Y: Integer);
begin
  inherited;
  if (Button <> mbLeft) or not Enabled then Exit;
  SetFocus;
  FMouseDownIndex := ItemAt(Y);
  if FMouseDownIndex >= 0 then
    SetItemIndex(FMouseDownIndex);
end;

procedure TFlatListBox.MouseMove(Shift: TShiftState; X, Y: Integer);
var
  Idx: Integer;
begin
  inherited;
  if PtInRect(ClientRect, Point(X, Y)) then
    Idx := ItemAt(Y)
  else
    Idx := -1;
  if FHotIndex = Idx then Exit;
  FHotIndex := Idx;
  Invalidate;
end;

procedure TFlatListBox.MouseUp(Button: TMouseButton; Shift: TShiftState;
  X, Y: Integer);
begin
  inherited;
  if Button <> mbLeft then Exit;
  FMouseDownIndex := -1;
end;

procedure TFlatListBox.KeyDown(var Key: Word; Shift: TShiftState);
var
  OldIndex: Integer;
begin
  inherited;
  if not Enabled then Exit;
  OldIndex := FItemIndex;
  case Key of
    VK_UP:
      begin
        if FItems.Count > 0 then
          SetItemIndex(EnsureRange(FItemIndex - 1, 0, FItems.Count - 1));
        Key := 0;
      end;
    VK_DOWN:
      begin
        if FItems.Count > 0 then
          SetItemIndex(EnsureRange(FItemIndex + 1, 0, FItems.Count - 1));
        Key := 0;
      end;
    VK_PRIOR:
      begin
        if FItems.Count > 0 then
          SetItemIndex(EnsureRange(FItemIndex - VisibleCount, 0, FItems.Count - 1));
        Key := 0;
      end;
    VK_NEXT:
      begin
        if FItems.Count > 0 then
          SetItemIndex(EnsureRange(FItemIndex + VisibleCount, 0, FItems.Count - 1));
        Key := 0;
      end;
    VK_HOME:
      begin
        if FItems.Count > 0 then
          SetItemIndex(0);
        Key := 0;
      end;
    VK_END:
      begin
        if FItems.Count > 0 then
          SetItemIndex(FItems.Count - 1);
        Key := 0;
      end;
  end;
  if (Key = 0) and (FItemIndex <> OldIndex) then
    Click;
end;

function TFlatListBox.DoMouseWheelUp(Shift: TShiftState; MousePos: TPoint): Boolean;
begin
  SetTopIndex(FTopIndex - 3);
  Result := True;
end;

function TFlatListBox.DoMouseWheelDown(Shift: TShiftState; MousePos: TPoint): Boolean;
begin
  SetTopIndex(FTopIndex + 3);
  Result := True;
end;

end.