ewsdr/FlatComboBox.pas

unit FlatComboBox;

{ Custom drop-down list with canvas rendering.
  Use instead of TComboBox where native widgetset styling is undesirable. }

{$mode objfpc}{$H+}

interface

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

type
  TFlatComboBox = class;

  TFlatComboPopup = class(TCustomControl)
  private
    FCombo: TFlatComboBox;
    FHotIndex: Integer;
    FTopIndex: Integer;
    function ItemAt(Y: Integer): Integer;
    procedure EnsureHotVisible;
  protected
    procedure Paint; override;
    procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
    procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
      X, Y: Integer); override;
    procedure DoExit; 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 CreatePopup(AOwner: TComponent; ACombo: TFlatComboBox); reintroduce;
  end;

  TFlatComboBox = class(TCustomControl)
  private
    FItems: TStringList;
    FItemIndex: Integer;
    FHot: Boolean;
    FDown: Boolean;
    FPopup: TFlatComboPopup;
    FOnChange: TNotifyEvent;
    FClrOuterBG: TColor;
    FClrBG: TColor;
    FClrBGHot: TColor;
    FClrBorder: TColor;
    FClrBorderHot: TColor;
    FClrText: TColor;
    FClrTextDim: TColor;
    FClrPopupBG: TColor;
    FClrPopupHot: TColor;
    FClrPopupSel: TColor;
    function DpiScale(V: Integer): Integer;
    function ItemHeight: Integer;
    function ArrowWidth: Integer;
    procedure ItemsChanged(Sender: TObject);
    procedure SetItemIndex(V: Integer);
    function GetText: string;
    procedure SetText(const V: string);
    procedure DoChange;
    procedure ClosePopup;
    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 MouseUp(Button: TMouseButton; Shift: TShiftState;
      X, Y: Integer); override;
    procedure KeyDown(var Key: Word; Shift: TShiftState); override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure SetAppTheme(const T: TAppTheme);
    procedure DropDown;

    property Items: TStringList read FItems;
    property ItemIndex: Integer read FItemIndex write SetItemIndex;
    property Text: string read GetText write SetText;
    property OnChange: TNotifyEvent read FOnChange write FOnChange;
    property Align;
    property Anchors;
    property Enabled;
    property Font;
    property ParentShowHint;
    property PopupMenu;
    property ShowHint;
    property TabOrder;
    property TabStop;
    property Tag;
    property Visible;
  end;

implementation

const
  BASE_ITEM_H = 24;
  BASE_ARROW_W = 24;
  BASE_PAD = 8;

{ TFlatComboPopup }

constructor TFlatComboPopup.CreatePopup(AOwner: TComponent; ACombo: TFlatComboBox);
begin
  inherited Create(AOwner);
  FCombo := ACombo;
  FHotIndex := ACombo.ItemIndex;
  FTopIndex := Max(0, FHotIndex - 4);
  TabStop := True;
  Cursor := crDefault;
  Color := ACombo.FClrPopupBG;
end;

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

procedure TFlatComboPopup.EnsureHotVisible;
var
  VisibleCount: Integer;
begin
  VisibleCount := Max(1, Height div FCombo.ItemHeight);
  if FHotIndex < FTopIndex then
    FTopIndex := FHotIndex
  else if FHotIndex >= FTopIndex + VisibleCount then
    FTopIndex := FHotIndex - VisibleCount + 1;
  FTopIndex := EnsureRange(FTopIndex, 0, Max(0, FCombo.Items.Count - VisibleCount));
end;

procedure TFlatComboPopup.Paint;
var
  i, ItemIdx, Y, TextY, VisibleCount: Integer;
  R: TRect;
begin
  Canvas.Brush.Color := FCombo.FClrPopupBG;
  Canvas.Brush.Style := bsSolid;
  Canvas.Pen.Style := psClear;
  Canvas.FillRect(ClientRect);

  Canvas.Font.Assign(FCombo.Font);
  VisibleCount := Max(1, Height div FCombo.ItemHeight);
  for i := 0 to VisibleCount - 1 do
  begin
    ItemIdx := FTopIndex + i;
    if ItemIdx >= FCombo.Items.Count then Break;
    Y := i * FCombo.ItemHeight;
    R := Rect(0, Y, Width, Y + FCombo.ItemHeight);
    if ItemIdx = FCombo.ItemIndex then
      Canvas.Brush.Color := FCombo.FClrPopupSel
    else if ItemIdx = FHotIndex then
      Canvas.Brush.Color := FCombo.FClrPopupHot
    else
      Canvas.Brush.Color := FCombo.FClrPopupBG;
    Canvas.FillRect(R);

    Canvas.Brush.Style := bsClear;
    Canvas.Font.Color := FCombo.FClrText;
    TextY := Y + (FCombo.ItemHeight - Canvas.TextHeight('Ag')) div 2;
    Canvas.TextOut(FCombo.DpiScale(BASE_PAD), TextY, FCombo.Items[ItemIdx]);
    Canvas.Brush.Style := bsSolid;
  end;

  Canvas.Pen.Color := FCombo.FClrBorder;
  Canvas.Pen.Style := psSolid;
  Canvas.Brush.Style := bsClear;
  Canvas.Rectangle(0, 0, Width, Height);
end;

procedure TFlatComboPopup.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 TFlatComboPopup.MouseDown(Button: TMouseButton; Shift: TShiftState;
  X, Y: Integer);
var
  Idx: Integer;
begin
  inherited;
  if Button <> mbLeft then Exit;
  if PtInRect(ClientRect, Point(X, Y)) then
  begin
    Idx := ItemAt(Y);
    if Idx >= 0 then
      FCombo.ItemIndex := Idx;
  end;
  FCombo.ClosePopup;
end;

procedure TFlatComboPopup.DoExit;
begin
  inherited;
  if Assigned(FCombo) then
    FCombo.ClosePopup;
end;

procedure TFlatComboPopup.KeyDown(var Key: Word; Shift: TShiftState);
begin
  inherited;
  case Key of
    VK_ESCAPE:
      begin
        FCombo.ClosePopup;
        Key := 0;
      end;
    VK_RETURN:
      begin
        if FHotIndex >= 0 then
          FCombo.ItemIndex := FHotIndex;
        FCombo.ClosePopup;
        Key := 0;
      end;
    VK_UP:
      begin
        FHotIndex := EnsureRange(FHotIndex - 1, 0, FCombo.Items.Count - 1);
        EnsureHotVisible;
        Invalidate;
        Key := 0;
      end;
    VK_DOWN:
      begin
        FHotIndex := EnsureRange(FHotIndex + 1, 0, FCombo.Items.Count - 1);
        EnsureHotVisible;
        Invalidate;
        Key := 0;
      end;
  end;
end;

function TFlatComboPopup.DoMouseWheelUp(Shift: TShiftState; MousePos: TPoint): Boolean;
begin
  FTopIndex := Max(0, FTopIndex - 1);
  Invalidate;
  Result := True;
end;

function TFlatComboPopup.DoMouseWheelDown(Shift: TShiftState; MousePos: TPoint): Boolean;
var
  VisibleCount: Integer;
begin
  VisibleCount := Max(1, Height div FCombo.ItemHeight);
  FTopIndex := Min(Max(0, FCombo.Items.Count - VisibleCount), FTopIndex + 1);
  Invalidate;
  Result := True;
end;

{ TFlatComboBox }

constructor TFlatComboBox.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  ControlStyle := ControlStyle + [csOpaque, csCaptureMouse, csClickEvents];
  FItems := TStringList.Create;
  FItems.OnChange := @ItemsChanged;
  FItemIndex := -1;
  Width := 140;
  Height := DpiScale(26);
  TabStop := True;
  Cursor := crDefault;

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

  FClrBG := TColor($001A1A1A);
  FClrOuterBG := TColor($00181818);
  FClrBGHot := TColor($00282828);
  FClrBorder := TColor($00444444);
  FClrBorderHot := TColor($00387838);
  FClrText := TColor($00E0E0E0);
  FClrTextDim := TColor($00888888);
  FClrPopupBG := TColor($00181818);
  FClrPopupHot := TColor($000C3010);
  FClrPopupSel := TColor($00183618);
end;

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

function TFlatComboBox.ItemHeight: Integer;
begin
  Result := DpiScale(BASE_ITEM_H);
  if Result < Canvas.TextHeight('Ag') + DpiScale(8) then
    Result := Canvas.TextHeight('Ag') + DpiScale(8);
end;

function TFlatComboBox.ArrowWidth: Integer;
begin
  Result := DpiScale(BASE_ARROW_W);
end;

destructor TFlatComboBox.Destroy;
begin
  ClosePopup;
  FItems.Free;
  inherited Destroy;
end;

procedure TFlatComboBox.SetAppTheme(const T: TAppTheme);
begin
  FClrBG := T.BtnNorm;
  FClrOuterBG := T.Panel;
  FClrBGHot := T.BtnHot;
  FClrBorder := T.Border;
  FClrBorderHot := T.Border;
  FClrText := T.Text;
  FClrTextDim := T.TextDim;
  FClrPopupBG := T.Panel;
  FClrPopupHot := T.BtnActive;
  FClrPopupSel := T.SliderTrackFill;
  Font.Color := T.Text;
  Invalidate;
end;

procedure TFlatComboBox.ItemsChanged(Sender: TObject);
begin
  if FItemIndex >= FItems.Count then
    FItemIndex := FItems.Count - 1;
  if FItems.Count = 0 then
    FItemIndex := -1;
  Invalidate;
end;

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

function TFlatComboBox.GetText: string;
begin
  if (FItemIndex >= 0) and (FItemIndex < FItems.Count) then
    Result := FItems[FItemIndex]
  else
    Result := '';
end;

procedure TFlatComboBox.SetText(const V: string);
var
  Idx: Integer;
begin
  Idx := FItems.IndexOf(V);
  if Idx >= 0 then
    ItemIndex := Idx
  else
  begin
    FItems.Add(V);
    ItemIndex := FItems.Count - 1;
  end;
end;

procedure TFlatComboBox.DoChange;
begin
  if Assigned(FOnChange) then
    FOnChange(Self);
end;

procedure TFlatComboBox.ClosePopup;
begin
  if FPopup = nil then Exit;
  FPopup.MouseCapture := False;
  FreeAndNil(FPopup);
  FDown := False;
  Invalidate;
end;

procedure TFlatComboBox.DropDown;
var
  Root: TCustomForm;
  P: TPoint;
  H, IH: Integer;
begin
  if (FPopup <> nil) or (FItems.Count = 0) then Exit;
  Root := GetParentForm(Self);
  if Root = nil then Exit;
  P := Root.ScreenToClient(ClientToScreen(Point(0, Height)));
  IH := ItemHeight;
  H := Min(FItems.Count * IH + 1, IH * 10 + 1);
  if P.Y + H > Root.ClientHeight then
    P.Y := Root.ScreenToClient(ClientToScreen(Point(0, 0))).Y - H;
  if P.Y < 0 then
    P.Y := 0;

  FPopup := TFlatComboPopup.CreatePopup(Root, Self);
  FPopup.Parent := Root;
  FPopup.SetBounds(P.X, P.Y, Width, H);
  FPopup.BringToFront;
  FPopup.Visible := True;
  FPopup.SetFocus;
  FPopup.MouseCapture := True;
  FDown := True;
  Invalidate;
end;

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

procedure TFlatComboBox.Paint;
var
  R: TRect;
  TextY, MidY, X, Pad, AW, Chevron: Integer;
  BG, Bdr: TColor;
  S: string;
begin
  R := ClientRect;
  if FHot or FDown or Focused then
  begin
    BG := FClrBGHot;
    Bdr := FClrBorderHot;
  end
  else
  begin
    BG := FClrBG;
    Bdr := FClrBorder;
  end;

  Canvas.Brush.Color := FClrOuterBG;
  Canvas.Brush.Style := bsSolid;
  Canvas.Pen.Style := psClear;
  Canvas.FillRect(R);

  Canvas.Brush.Color := BG;
  Canvas.Brush.Style := bsSolid;
  Canvas.Pen.Color := Bdr;
  Canvas.Pen.Style := psSolid;
  Canvas.Pen.Width := 1;
  Canvas.Rectangle(R.Left, R.Top, R.Right, R.Bottom);

  Pad := DpiScale(BASE_PAD);
  AW := ArrowWidth;
  Canvas.Font.Assign(Font);
  if Enabled then
    Canvas.Font.Color := FClrText
  else
    Canvas.Font.Color := FClrTextDim;
  Canvas.Brush.Style := bsClear;
  S := Text;
  TextY := (Height - Canvas.TextHeight('Ag')) div 2;
  Canvas.TextRect(Rect(Pad, 0, Width - AW - DpiScale(4), Height), Pad, TextY, S);

  X := Width - AW div 2;
  MidY := Height div 2;
  Chevron := DpiScale(4);
  Canvas.Pen.Color := FClrTextDim;
  Canvas.Pen.Style := psSolid;
  Canvas.Pen.Width := Max(1, DpiScale(2));
  Canvas.Line(X - Chevron, MidY - Chevron div 2, X, MidY + Chevron div 2);
  Canvas.Line(X, MidY + Chevron div 2, X + Chevron, MidY - Chevron div 2);
  Canvas.Pen.Width := 1;
end;

procedure TFlatComboBox.MouseEnter;
begin
  inherited;
  FHot := True;
  Invalidate;
end;

procedure TFlatComboBox.MouseLeave;
begin
  inherited;
  FHot := False;
  Invalidate;
end;

procedure TFlatComboBox.MouseDown(Button: TMouseButton; Shift: TShiftState;
  X, Y: Integer);
begin
  inherited;
  if (Button = mbLeft) and Enabled then
    SetFocus;
end;

procedure TFlatComboBox.MouseUp(Button: TMouseButton; Shift: TShiftState;
  X, Y: Integer);
begin
  inherited;
  if (Button = mbLeft) and Enabled and PtInRect(ClientRect, Point(X, Y)) then
  begin
    if FPopup <> nil then
      ClosePopup
    else
      DropDown;
  end;
end;

procedure TFlatComboBox.KeyDown(var Key: Word; Shift: TShiftState);
begin
  inherited;
  case Key of
    VK_SPACE, VK_RETURN:
      begin
        DropDown;
        Key := 0;
      end;
    VK_UP:
      begin
        ItemIndex := FItemIndex - 1;
        Key := 0;
      end;
    VK_DOWN:
      begin
        ItemIndex := FItemIndex + 1;
        Key := 0;
      end;
  end;
end;

end.