mirror of
https://git.vladimir.cc/vladimir/ewsdr.git
synced 2026-08-26 04:47:35 +00:00
Add custom flat form controls
This commit is contained in:
@@ -0,0 +1,285 @@
|
||||
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.
|
||||
Reference in New Issue
Block a user