ewsdr/FlatCheckBox.pas

unit FlatCheckBox;

{ Custom checkbox with canvas rendering.
  Use instead of TCheckBox where native widgetset styling is undesirable. }

{$mode objfpc}{$H+}

interface

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

type
  TFlatCheckBox = class(TCustomControl)
  private
    FChecked: Boolean;
    FHot: Boolean;
    FDown: Boolean;
    FOnChange: TNotifyEvent;
    FClrBG: TColor;
    FClrBox: TColor;
    FClrBoxChecked: TColor;
    FClrBoxHot: TColor;
    FClrBorder: TColor;
    FClrBorderHot: TColor;
    FClrCheck: TColor;
    FClrText: TColor;
    FClrTextDisabled: TColor;
    function DpiScale(V: Integer): Integer;
    procedure SetChecked(V: Boolean);
    procedure DoChange;
    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_BOX_SIZE = 16;
  BASE_BOX_LEFT = 1;
  BASE_TEXT_GAP = 8;
  BASE_CORNER   = 2;

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

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

  FClrBG := TColor($00181818);
  FClrBox := TColor($001A1A1A);
  FClrBoxChecked := TColor($000C3010);
  FClrBoxHot := TColor($00282828);
  FClrBorder := TColor($00444444);
  FClrBorderHot := TColor($00387838);
  FClrCheck := TColor($0000FF88);
  FClrText := TColor($00CCCCCC);
  FClrTextDisabled := TColor($00666666);
end;

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

procedure TFlatCheckBox.SetAppTheme(const T: TAppTheme);
begin
  FClrBG := T.Panel;
  FClrBox := T.BtnNorm;
  FClrBoxChecked := T.BtnActive;
  FClrBoxHot := T.BtnHot;
  FClrBorder := T.BtnBorderNorm;
  FClrBorderHot := T.BtnBorderActive;
  FClrCheck := T.BtnTextActive;
  FClrText := T.Text;
  FClrTextDisabled := T.TextDim;
  Font.Color := T.Text;
  Invalidate;
end;

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

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

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

procedure TFlatCheckBox.Paint;
var
  BoxSize, BoxLeft, BoxTop, TextGap, TextTop, TX, Corner: Integer;
  R: TRect;
  BoxColor, BorderColor, TextColor: TColor;

  procedure DrawCheckMark(const AR: TRect);
  var
    P: array[0..6] of TPoint;
    W, H: Integer;

    function PX(V: Integer): Integer;
    begin
      Result := AR.Left + MulDiv(V, W, BASE_BOX_SIZE);
    end;

    function PY(V: Integer): Integer;
    begin
      Result := AR.Top + MulDiv(V, H, BASE_BOX_SIZE);
    end;
  begin
    W := AR.Right - AR.Left;
    H := AR.Bottom - AR.Top;
    P[0] := Point(PX(4),  PY(8));
    P[1] := Point(PX(6),  PY(8));
    P[2] := Point(PX(7),  PY(10));
    P[3] := Point(PX(12), PY(4));
    P[4] := Point(PX(13), PY(6));
    P[5] := Point(PX(8),  PY(12));
    P[6] := Point(PX(6),  PY(12));

    Canvas.Brush.Color := FClrCheck;
    Canvas.Brush.Style := bsSolid;
    Canvas.Pen.Style := psClear;
    Canvas.Polygon(P);
  end;
begin
  Canvas.Brush.Color := FClrBG;
  Canvas.Brush.Style := bsSolid;
  Canvas.Pen.Style := psClear;
  Canvas.FillRect(ClientRect);

  BoxSize := DpiScale(BASE_BOX_SIZE);
  if BoxSize > Height - DpiScale(4) then
    BoxSize := Height - DpiScale(4);
  if BoxSize < DpiScale(10) then
    BoxSize := DpiScale(10);
  BoxLeft := DpiScale(BASE_BOX_LEFT);
  BoxTop := (Height - BoxSize) div 2;
  TextGap := DpiScale(BASE_TEXT_GAP);
  Corner := DpiScale(BASE_CORNER);
  R := Rect(BoxLeft, BoxTop, BoxLeft + BoxSize, BoxTop + BoxSize);

  if FChecked then
    BoxColor := FClrBoxChecked
  else if FHot or Focused then
    BoxColor := FClrBoxHot
  else
    BoxColor := FClrBox;

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

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

  Canvas.Brush.Color := BoxColor;
  Canvas.Brush.Style := bsSolid;
  Canvas.Pen.Color := BorderColor;
  Canvas.Pen.Style := psSolid;
  Canvas.Pen.Width := 1;
  Canvas.RoundRect(R.Left, R.Top, R.Right - 1, R.Bottom - 1, CORNER * 2, CORNER * 2);

  if FChecked then
    DrawCheckMark(R);

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

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

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

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

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

procedure TFlatCheckBox.KeyDown(var Key: Word; Shift: TShiftState);
begin
  inherited;
  if Enabled and ((Key = VK_SPACE) or (Key = VK_RETURN)) then
  begin
    Checked := not Checked;
    Click;
    Key := 0;
  end;
end;

end.