mirror of
https://git.vladimir.cc/vladimir/ewsdr.git
synced 2026-08-25 19:45:09 +00:00
Add custom flat form controls
This commit is contained in:
@@ -0,0 +1,294 @@
|
||||
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;
|
||||
|
||||
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;
|
||||
function DpiScale(V: Integer): Integer;
|
||||
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.Name := 'Courier New';
|
||||
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;
|
||||
|
||||
function TFlatRadioButton.DpiScale(V: Integer): Integer;
|
||||
begin
|
||||
Result := MulDiv(V, Screen.PixelsPerInch, 96);
|
||||
if (V > 0) and (Result < 1) then
|
||||
Result := 1;
|
||||
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.
|
||||
Reference in New Issue
Block a user