ewsdr/FlatButton.pas

unit FlatButton;

{ Кнопка с полным контролем цвета на Windows и Linux.
  Используй вместо TButton везде где нужна тёмная тема. }

{$mode objfpc}{$H+}

interface

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

type
  TFlatButton = class(TGraphicControl)
  private
    FActive:    Boolean;
    FHot:       Boolean;
    FClrNorm:   TColor;
    FClrActive: TColor;
    FClrHot:    TColor;
    FClrBorder: TColor;
    FClrText:   TColor;
    FClrTextAct:TColor;
    FOnClick:   TNotifyEvent;
    procedure SetActive(V: Boolean);
  protected
    procedure Paint; override;
    procedure MouseEnter; override;
    procedure MouseLeave; override;
    procedure CMTextChanged(var Msg: TLMessage); message CM_TEXTCHANGED;
    procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
                        X, Y: Integer); override;
    procedure MouseUp(Button: TMouseButton; Shift: TShiftState;
                      X, Y: Integer); override;
  public
    constructor Create(AOwner: TComponent); override;

    property Active:    Boolean read FActive  write SetActive;
    property ClrNorm:   TColor  read FClrNorm   write FClrNorm;
    property ClrActive: TColor  read FClrActive  write FClrActive;
    property ClrHot:    TColor  read FClrHot     write FClrHot;
    property ClrBorder: TColor  read FClrBorder  write FClrBorder;
    property ClrText:   TColor  read FClrText    write FClrText;
    property ClrTextAct:TColor  read FClrTextAct write FClrTextAct;
    property OnClick:    TNotifyEvent read FOnClick write FOnClick;
    property OnMouseDown;
    property OnMouseUp;
    property Caption;
    property Font;
    property Enabled;
    property Visible;
  end;

// Отрисовка кнопки в стиле TFlatButton на произвольном канвасе/прямоугольнике.
// Используется и TFlatButton.Paint, и оверлеями, которые рендерятся в битмап
// (VfoOverlay) — чтобы вид кнопок был одинаковым по всей программе. Шрифт
// берётся текущий у канваса (вызывающий выставляет Name/Size заранее).
procedure PaintFlatButton(C: TCanvas; const R: TRect; const ACaption: string;
  AActive, AHot: Boolean;
  ClrNorm, ClrActive, ClrHot, ClrBorder, ClrText, ClrTextAct: TColor);

// Фабрика — аналог MakeBtn, возвращает TFlatButton
function MakeFlatBtn(AParent: TWinControl; const ACap: string;
  ALeft, ATop, AW, AH: Integer;
  AHandler: TNotifyEvent;
  ClrNorm:    TColor = TColor($00202020);
  ClrActive:  TColor = TColor($00003300);
  ClrHot:     TColor = TColor($00303030);
  ClrBorder:  TColor = TColor($00404040);
  ClrText:    TColor = TColor($00E0E0E0);
  ClrTextAct: TColor = TColor($0000FF88)): TFlatButton;

implementation

constructor TFlatButton.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FActive     := False;
  FHot        := False;
  FClrNorm    := TColor($00202020);
  FClrActive  := TColor($00003300);
  FClrHot     := TColor($00303030);
  FClrBorder  := TColor($00404040);
  FClrText    := TColor($00E0E0E0);
  FClrTextAct := TColor($0000FF88);
  Cursor      := crHandPoint;
end;

procedure TFlatButton.SetActive(V: Boolean);
begin
  if FActive = V then Exit;
  FActive := V;
  Invalidate;
end;

procedure PaintFlatButton(C: TCanvas; const R: TRect; const ACaption: string;
  AActive, AHot: Boolean;
  ClrNorm, ClrActive, ClrHot, ClrBorder, ClrText, ClrTextAct: TColor);
const
  CORNER = 3;
var
  BG: TColor;
  TW, TH: Integer;
begin
  if AActive then      BG := ClrActive
  else if AHot then    BG := ClrHot
  else                 BG := ClrNorm;

  // Фон со скруглёнными углами
  C.Brush.Color := BG;
  C.Brush.Style := bsSolid;
  C.Pen.Color   := BG;
  C.Pen.Style   := psSolid;
  C.RoundRect(R.Left, R.Top, R.Right, R.Bottom, CORNER * 2, CORNER * 2);

  // Рамка
  C.Pen.Color   := ClrBorder;
  C.Brush.Style := bsClear;
  C.RoundRect(R.Left, R.Top, R.Right - 1, R.Bottom - 1, CORNER * 2, CORNER * 2);

  // Текст
  if AActive then C.Font.Color := ClrTextAct
  else            C.Font.Color := ClrText;
  C.Brush.Style := bsClear;
  TW := C.TextWidth(ACaption);
  TH := C.TextHeight('A');
  C.TextOut(R.Left + (R.Right - R.Left - TW) div 2,
            R.Top  + (R.Bottom - R.Top - TH) div 2, ACaption);
end;

procedure TFlatButton.Paint;
begin
  PaintFlatButton(Canvas, ClientRect, Caption, FActive, FHot,
    FClrNorm, FClrActive, FClrHot, FClrBorder, FClrText, FClrTextAct);
end;

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

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

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

procedure TFlatButton.MouseDown(Button: TMouseButton; Shift: TShiftState;
  X, Y: Integer);
begin
  inherited;
end;

procedure TFlatButton.MouseUp(Button: TMouseButton; Shift: TShiftState;
  X, Y: Integer);
begin
  inherited;
  if (Button = mbLeft) and PtInRect(ClientRect, Point(X, Y)) then
    if Assigned(FOnClick) then FOnClick(Self);
end;

function MakeFlatBtn(AParent: TWinControl; const ACap: string;
  ALeft, ATop, AW, AH: Integer;
  AHandler: TNotifyEvent;
  ClrNorm, ClrActive, ClrHot, ClrBorder, ClrText, ClrTextAct: TColor): TFlatButton;
begin
  Result := TFlatButton.Create(AParent);
  Result.Parent      := AParent;
  Result.Caption     := ACap;
  Result.Left        := ALeft;
  Result.Top         := ATop;
  Result.Width       := AW;
  Result.Height      := AH;
  Result.OnClick     := AHandler;
  Result.ClrNorm     := ClrNorm;
  Result.ClrActive   := ClrActive;
  Result.ClrHot      := ClrHot;
  Result.ClrBorder   := ClrBorder;
  Result.ClrText     := ClrText;
  Result.ClrTextAct  := ClrTextAct;
  Result.Font.Name   := 'Courier New';
  Result.Font.Size   := 8;
  Result.Font.Color  := ClrText;
end;

end.