ewsdr/FlatRadioButton.pas

unit FlatRadioButton;

{ Custom radio button with canvas rendering.
  Use instead of TRadioButton where native widgetset styling is undesirable. }

{$mode objfpc}{$H+}

interface

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

type
  TFlatRadioButton = class(TCustomControl)
  private
    FChecked: Boolean;
    FHot: Boolean;
    FDown: Boolean;
    FOnChange: TNotifyEvent;
    FClrBG: TColor;
    FClrCircle: TColor;
    FClrCircleChecked: TColor;
    FClrCircleHot: TColor;
    FClrBorder: TColor;
    FClrBorderHot: TColor;
    FClrDot: TColor;
    FClrText: TColor;
    FClrTextDisabled: TColor;
    procedure SetCheckedSilently(V: Boolean);
    procedure SetChecked(V: Boolean);
    procedure DoChange;
    procedure UncheckSiblings;
    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;
    procedure SetAppTheme(const T: TAppTheme);

    property Checked: Boolean read FChecked write SetChecked;
    property OnChange: TNotifyEvent read FOnChange write FOnChange;
    property Align;
    property Anchors;
    property Caption;
    property Enabled;
    property Font;
    property ParentShowHint;
    property PopupMenu;
    property ShowHint;
    property TabOrder;
    property TabStop;
    property Tag;
    property Visible;
    property OnClick;
  end;

implementation

const
  BASE_CIRCLE_SIZE = 16;
  BASE_CIRCLE_LEFT = 1;
  BASE_TEXT_GAP = 8;

constructor TFlatRadioButton.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  ControlStyle := ControlStyle + [csOpaque, csCaptureMouse, csClickEvents];
  Width := 160;
  Height := 22;
  TabStop := True;
  Cursor := crHandPoint;

  Font.Size := 9;

  FClrBG := TColor($00181818);
  FClrCircle := TColor($001A1A1A);
  FClrCircleChecked := TColor($000C3010);
  FClrCircleHot := TColor($00282828);
  FClrBorder := TColor($00444444);
  FClrBorderHot := TColor($00387838);
  FClrDot := TColor($0000FF88);
  FClrText := TColor($00CCCCCC);
  FClrTextDisabled := TColor($00666666);
end;

procedure TFlatRadioButton.SetAppTheme(const T: TAppTheme);
begin
  FClrBG := T.Panel;
  FClrCircle := T.BtnNorm;
  FClrCircleChecked := T.BtnActive;
  FClrCircleHot := T.BtnHot;
  FClrBorder := T.BtnBorderNorm;
  FClrBorderHot := T.BtnBorderActive;
  FClrDot := T.BtnTextActive;
  FClrText := T.Text;
  FClrTextDisabled := T.TextDim;
  Font.Color := T.Text;
  Invalidate;
end;

procedure TFlatRadioButton.SetChecked(V: Boolean);
begin
  if FChecked = V then Exit;
  if V then
    UncheckSiblings;
  FChecked := V;
  Invalidate;
  DoChange;
end;

procedure TFlatRadioButton.SetCheckedSilently(V: Boolean);
begin
  if FChecked = V then Exit;
  FChecked := V;
  Invalidate;
end;

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

procedure TFlatRadioButton.UncheckSiblings;
var
  i: Integer;
  Ctrl: TControl;
begin
  if Parent = nil then Exit;
  for i := 0 to Parent.ControlCount - 1 do
  begin
    Ctrl := Parent.Controls[i];
    if (Ctrl <> Self) and (Ctrl is TFlatRadioButton) then
      TFlatRadioButton(Ctrl).SetCheckedSilently(False);
  end;
end;

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

procedure TFlatRadioButton.Paint;
var
  CircleSize, CircleLeft, CircleTop, DotSize, TextGap, TextTop, TX: Integer;
  R: TRect;
  CircleColor, BorderColor, TextColor: TColor;

  procedure FillCircle(CX, CY, Radius: Integer; AColor: TColor);
  var
    DY, DX: Integer;
  begin
    Canvas.Brush.Color := AColor;
    Canvas.Brush.Style := bsSolid;
    Canvas.Pen.Style := psClear;
    for DY := -Radius to Radius do
    begin
      DX := Trunc(Sqrt(Sqr(Radius) - Sqr(DY)));
      Canvas.FillRect(Rect(CX - DX, CY + DY, CX + DX + 1, CY + DY + 1));
    end;
  end;
begin
  Canvas.Brush.Color := FClrBG;
  Canvas.Brush.Style := bsSolid;
  Canvas.Pen.Style := psClear;
  Canvas.FillRect(ClientRect);

  CircleSize := DpiScale(BASE_CIRCLE_SIZE);
  if CircleSize > Height - DpiScale(4) then
    CircleSize := Height - DpiScale(4);
  if CircleSize < DpiScale(10) then
    CircleSize := DpiScale(10);
  CircleLeft := DpiScale(BASE_CIRCLE_LEFT);
  CircleTop := (Height - CircleSize) div 2;
  TextGap := DpiScale(BASE_TEXT_GAP);
  R := Rect(CircleLeft, CircleTop, CircleLeft + CircleSize, CircleTop + CircleSize);

  if FChecked then
    CircleColor := FClrCircleChecked
  else if FHot or Focused then
    CircleColor := FClrCircleHot
  else
    CircleColor := FClrCircle;

  if FHot or Focused then
    BorderColor := FClrBorderHot
  else
    BorderColor := FClrBorder;

  if not Enabled then
  begin
    CircleColor := FClrBG;
    BorderColor := FClrBorder;
    TextColor := FClrTextDisabled;
  end
  else
    TextColor := FClrText;

  FillCircle((R.Left + R.Right) div 2, (R.Top + R.Bottom) div 2,
    CircleSize div 2, BorderColor);
  FillCircle((R.Left + R.Right) div 2, (R.Top + R.Bottom) div 2,
    Max(1, CircleSize div 2 - DpiScale(1)), CircleColor);

  if FChecked then
  begin
    DotSize := Max(DpiScale(5), CircleSize div 2 - DpiScale(2));
    if DotSize mod 2 = 0 then
      Dec(DotSize);
    FillCircle((R.Left + R.Right) div 2, (R.Top + R.Bottom) div 2,
      DotSize div 2, FClrDot);
  end;

  if Caption <> '' then
  begin
    Canvas.Font.Assign(Font);
    Canvas.Font.Color := TextColor;
    Canvas.Brush.Style := bsClear;
    TX := R.Right + TextGap;
    TextTop := (Height - Canvas.TextHeight('Ag')) div 2;
    Canvas.TextOut(TX, TextTop, Caption);
  end;
end;

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

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

procedure TFlatRadioButton.MouseDown(Button: TMouseButton; Shift: TShiftState;
  X, Y: Integer);
begin
  inherited;
  if (Button <> mbLeft) or not Enabled then Exit;
  SetFocus;
  FDown := True;
  Invalidate;
end;

procedure TFlatRadioButton.MouseUp(Button: TMouseButton; Shift: TShiftState;
  X, Y: Integer);
begin
  inherited;
  if Button <> mbLeft then Exit;
  FDown := False;
  if Enabled and PtInRect(ClientRect, Point(X, Y)) then
  begin
    if not Checked then
      Checked := True;
    Click;
  end;
  Invalidate;
end;

procedure TFlatRadioButton.KeyDown(var Key: Word; Shift: TShiftState);
begin
  inherited;
  if not Enabled then Exit;
  if Key in [VK_SPACE, VK_RETURN] then
  begin
    if not Checked then
      Checked := True;
    Click;
    Key := 0;
  end;
end;

end.