1 // SPDX-License-Identifier: LGPL-3.0-only (modified to allow linking)
2 unit BGRAThemeButton;
3
4 {$mode objfpc}{$H+}
5
6 interface
7
8 uses
9 Classes, SysUtils, LResources, Forms, Controls, Graphics, Dialogs,
10 BGRATheme, Types, ExtCtrls, BGRASVGImageList;
11
12 type
13
14 { TBGRAThemeButton }
15
16 TBGRAThemeButton = class(TBGRAThemeControl)
17 private
18 FImageIndex: integer;
19 FImageList: TBGRASVGImageList;
20 FModalResult: TModalResult;
21 FState: TBGRAThemeButtonState;
22 FTimerHover: TTimer;
23 procedure SetImageIndex(AValue: integer);
24 procedure SetImageList(AValue: TBGRASVGImageList);
25 procedure SetState(AValue: TBGRAThemeButtonState);
26 procedure TimerHoverElapse(Sender: TObject);
27 protected
28 procedure Notification(AComponent: TComponent; Operation: TOperation); override;
GetControlClassDefaultSizenull29 class function GetControlClassDefaultSize: TSize; override;
30 procedure MouseEnter; override;
31 procedure MouseLeave; override;
32 procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
33 X, Y: integer); override;
34 procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: integer); override;
35 procedure Click; override;
36 procedure SetEnabled(Value: boolean); override;
37 procedure TextChanged; override;
38 procedure Paint; override;
39 procedure Resize; override;
40 procedure UpdateHoverState;
41 property State: TBGRAThemeButtonState read FState write SetState;
42 public
43 constructor Create(AOwner: TComponent); override;
44 published
45 property ModalResult: TModalResult
46 read FModalResult write FModalResult default mrNone;
47 property Align;
48 property Anchors;
49 property BorderSpacing;
50 property Caption;
51 property Enabled;
52 property Font;
53 property ImageList: TBGRASVGImageList read FImageList write SetImageList;
54 property ImageIndex: integer read FImageIndex write SetImageIndex;
55 property OnClick;
56 end;
57
58 procedure Register;
59
60 implementation
61
62 uses BGRABitmapTypes;
63
64 procedure Register;
65 begin
66 RegisterComponents('BGRA Themes', [TBGRAThemeButton]);
67 end;
68
69 { TBGRAThemeButton }
70
71 procedure TBGRAThemeButton.SetState(AValue: TBGRAThemeButtonState);
72 begin
73 if FState = AValue then
74 Exit;
75 FState := AValue;
76 FTimerHover.Enabled := (FState = btbsHover);
77 Invalidate;
78 end;
79
80 procedure TBGRAThemeButton.SetImageIndex(AValue: integer);
81 begin
82 if FImageIndex = AValue then
83 Exit;
84 FImageIndex := AValue;
85 Invalidate;
86 end;
87
88 procedure TBGRAThemeButton.SetImageList(AValue: TBGRASVGImageList);
89 begin
90 if FImageList = AValue then
91 Exit;
92 FImageList := AValue;
93 Invalidate;
94 end;
95
96 procedure TBGRAThemeButton.TimerHoverElapse(Sender: TObject);
97 begin
98 UpdateHoverState;
99 end;
100
101 procedure TBGRAThemeButton.Notification(AComponent: TComponent;
102 Operation: TOperation);
103 begin
104 inherited Notification(AComponent, Operation);
105 if (Operation = opRemove) and (AComponent = FImageList) then
106 FImageList := nil;
107 end;
108
TBGRAThemeButton.GetControlClassDefaultSizenull109 class function TBGRAThemeButton.GetControlClassDefaultSize: TSize;
110 begin
111 Result.CX := 125;
112 Result.CY := 35;
113 end;
114
115 procedure TBGRAThemeButton.MouseEnter;
116 begin
117 inherited MouseEnter;
118 if Enabled then
119 State := btbsHover
120 else
121 State := btbsDisabled;
122 end;
123
124 procedure TBGRAThemeButton.MouseLeave;
125 begin
126 inherited MouseLeave;
127 if Enabled then
128 State := btbsNormal
129 else
130 State := btbsDisabled;
131 end;
132
133 procedure TBGRAThemeButton.MouseDown(Button: TMouseButton; Shift: TShiftState;
134 X, Y: integer);
135 begin
136 inherited MouseDown(Button, Shift, X, Y);
137 State := btbsActive;
138 end;
139
140 procedure TBGRAThemeButton.MouseUp(Button: TMouseButton; Shift: TShiftState;
141 X, Y: integer);
142 begin
143 inherited MouseUp(Button, Shift, X, Y);
144 UpdateHoverState;
145 end;
146
147 procedure TBGRAThemeButton.Click;
148 var
149 Form: TCustomForm;
150 begin
151 UpdateHoverState;
152 if ModalResult <> mrNone then
153 begin
154 Form := GetParentForm(Self);
155 if Form <> nil then
156 Form.ModalResult := ModalResult;
157 end;
158 inherited Click;
159 end;
160
161 procedure TBGRAThemeButton.SetEnabled(Value: boolean);
162 begin
163 inherited SetEnabled(Value);
164 if Value then
165 State := btbsNormal
166 else
167 State := btbsDisabled;
168 end;
169
170 procedure TBGRAThemeButton.TextChanged;
171 begin
172 inherited TextChanged;
173 Invalidate;
174 end;
175
176 procedure TBGRAThemeButton.Paint;
177 var
178 surface: TBGRAThemeSurface;
179 begin
180 Canvas.Font.Assign(Font);
181 surface := TBGRAThemeSurface.Create(self);
182 try
183 if Assigned(Theme) then
184 Theme.DrawButton(Caption, FState, Focused, ClientRect, surface, FImageIndex, FImageList)
185 else
186 BGRADefaultTheme.DrawButton(Caption, FState, Focused, ClientRect, surface, FImageIndex, FImageList);
187 finally
188 surface.Free;
189 end;
190 end;
191
192 procedure TBGRAThemeButton.Resize;
193 begin
194 Invalidate;
195 inherited Resize;
196 end;
197
198 procedure TBGRAThemeButton.UpdateHoverState;
199 var
200 p: TPoint;
201 begin
202 p := ScreenToClient(Mouse.CursorPos);
203 if (p.x >= 0) and (p.x <= Width) and (p.y >= 0) and (p.y <= Height) then
204 State := btbsHover
205 else
206 if Enabled then
207 State := btbsNormal
208 else
209 State := btbsDisabled;
210 end;
211
212 constructor TBGRAThemeButton.Create(AOwner: TComponent);
213 begin
214 inherited Create(AOwner);
215 FState := btbsNormal;
216
217 ControlStyle := ControlStyle + [csParentBackground];
218
219 with GetControlClassDefaultSize do
220 SetInitialBounds(0, 0, CX, CY);
221
222 FTimerHover := TTimer.Create(self);
223 FTimerHover.Enabled := False;
224 FTimerHover.Interval := 100;
225 FTimerHover.OnTimer := @TimerHoverElapse;
226 end;
227
228 end.
229