1 { TCheckBoxThemed
2
3 Copyright (C) 2017 Lazarus team
4
5 This library is free software; you can redistribute it and/or modify it
6 under the same terms as the Lazarus Component Library (LCL)
7
8 See the file COPYING.modifiedLGPL.txt, included in this distribution,
9 for details about the license.
10
11 }
12 unit CheckBoxThemed;
13 {$mode objfpc}{$H+}
14
15 interface
16
17 uses
18 Classes, SysUtils, Types, Math,
19 // LCL
20 Controls, StdCtrls, Graphics, ActnList, Forms,
21 LCLIntf, LMessages, LCLProc, LCLType, Themes,
22 // LazUtils
23 LazMethodList;
24
25 type
26 TCustomCheckBoxThemed = class;
27
28 { TCheckBoxThemedActionLink }
29 TCheckBoxThemedActionLink = class(TWinControlActionLink)
30 protected
31 FClientCheckBoxThemed: TCustomCheckBoxThemed;
32 procedure AssignClient(AClient: TObject); override;
33 procedure SetChecked(Value: Boolean); override;
34 public
IsCheckedLinkednull35 function IsCheckedLinked: Boolean; override;
36 end;
37
38 TCheckBoxThemedActionLinkClass = class of TCheckBoxThemedActionLink;
39
40 { TCustomCheckBoxThemed }
41 TCustomCheckBoxThemed = class(TCustomControl)
42 private
43 FAlignment: TLeftRight;
44 FAllowGrayed: Boolean;
45 FCheckBoxHovered: Boolean;
46 FCheckFromAction: Boolean;
47 FOnChange: TNotifyEvent;
48 FState: TCheckBoxState;
GetCheckednull49 function GetChecked: Boolean;
50 procedure SetAlignment(AValue: TLeftRight);
51 procedure SetCheckBoxHovered(AValue: Boolean);
52 procedure SetChecked(AValue: Boolean);
53 procedure SetState(AValue: TCheckBoxState);
54 private class var
55 FThemeCheckBoxSize: TSize;
56 protected
GetCheckBoxSizenull57 class function GetCheckBoxSize(const PixelsPerInch: Integer): TSize;
58 protected
59 CheckBoxPressed: Boolean;
60 KnobPosUnchecked, KnobPosChecked, KnobPosGrayed: Integer;
61 procedure CalculatePreferredSize(var PreferredWidth, PreferredHeight: Integer;
62 {%H-}WithThemeSpace: Boolean); override;
63 procedure CMBiDiModeChanged(var {%H-}Message: TLMessage); message CM_BIDIMODECHANGED;
64 procedure CMEnabledChanged(var Message: TLMessage); message CM_ENABLEDCHANGED;
65 class procedure InitCheckBoxSize;
DialogCharnull66 function DialogChar(var Message: TLMKey): Boolean; override;
67 procedure DoClick;
68 procedure DoEnter; override;
69 procedure DoExit; override;
GetActionLinkClassnull70 function GetActionLinkClass: TControlActionLinkClass; override;
71 procedure KeyDown(var Key: Word; Shift: TShiftState); override;
72 procedure KeyUp(var Key: Word; Shift: TShiftState); override;
73 procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
74 procedure MouseEnter; override;
75 procedure MouseLeave; override;
76 procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
77 procedure Paint; override;
78 procedure TextChanged; override;
79 procedure WMSize(var Message: TLMSize); message LM_SIZE;
80 property CheckBoxHovered: Boolean read FCheckBoxHovered write SetCheckBoxHovered;
81 property CheckFromAction: Boolean read FCheckFromAction write FCheckFromAction;
82 protected const
83 cFocusBorder: SmallInt = 2;
84 cIndent: SmallInt = 5;
85 public
86 class procedure PaintSelf(ACanvas: TCanvas; ACaption: string; ARect: TRect;
87 AState: TCheckBoxState; ARightToLeft, AHovered, APressed, AFocused: Boolean;
88 AAlignment: TLeftRight; AEnabled: Boolean = True);
89 constructor Create(AOwner: TComponent); override;
90 property Alignment: TLeftRight read FAlignment write SetAlignment default taRightJustify;
91 property AllowGrayed: Boolean read FAllowGrayed write FAllowGrayed default False;
92 property Checked: Boolean read GetChecked write SetChecked default False;
93 property State: TCheckBoxState read FState write SetState default cbUnchecked;
94 property OnChange: TNotifyEvent read FOnChange write FOnChange;
95 end;
96
97 { TCheckBoxThemed }
98 TCheckBoxThemed = class(TCustomCheckBoxThemed)
99 published
100 property Action;
101 property Align;
102 property Alignment;
103 property AllowGrayed;
104 property Anchors;
105 property AutoSize default True;
106 property BiDiMode;
107 property BorderSpacing;
108 property Caption;
109 property Checked;
110 property Color;
111 property Constraints;
112 property Cursor;
113 property DragCursor;
114 property DragKind;
115 property DragMode;
116 property Enabled;
117 property Font;
118 property Height;
119 property HelpContext;
120 property HelpKeyword;
121 property HelpType;
122 property Hint;
123 property Left;
124 property ParentBiDiMode;
125 property ParentColor;
126 property ParentFont;
127 property ParentShowHint;
128 property PopupMenu;
129 property ShowHint;
130 property State;
131 property TabOrder;
132 property TabStop default True;
133 property Top;
134 property Visible;
135 property Width;
136 property OnChangeBounds;
137 property OnChange;
138 property OnClick;
139 property OnContextPopup;
140 property OnDragDrop;
141 property OnDragOver;
142 property OnEditingDone;
143 property OnEndDrag;
144 property OnEnter;
145 property OnExit;
146 property OnKeyDown;
147 property OnKeyPress;
148 property OnKeyUp;
149 property OnMouseDown;
150 property OnMouseEnter;
151 property OnMouseLeave;
152 property OnMouseMove;
153 property OnMouseUp;
154 property OnMouseWheel;
155 property OnMouseWheelDown;
156 property OnMouseWheelUp;
157 property OnResize;
158 property OnStartDrag;
159 property OnUTF8KeyPress;
160 end;
161
162 implementation
163
164 { TCheckBoxThemedActionLink }
165
166 procedure TCheckBoxThemedActionLink.AssignClient(AClient: TObject);
167 begin
168 inherited AssignClient(AClient);
169 FClientCheckBoxThemed := AClient as TCustomCheckBoxThemed;
170 end;
171
IsCheckedLinkednull172 function TCheckBoxThemedActionLink.IsCheckedLinked: Boolean;
173 begin
174 Result := inherited IsCheckedLinked and
175 (FClientCheckBoxThemed.Checked = (Action as TCustomAction).Checked);
176 end;
177
178 procedure TCheckBoxThemedActionLink.SetChecked(Value: Boolean);
179 begin
180 if IsCheckedLinked then begin
181 FClientCheckBoxThemed.CheckFromAction := True;
182 try
183 FClientCheckBoxThemed.Checked := Value;
184 finally
185 FClientCheckBoxThemed.CheckFromAction := False;
186 end;
187 end;
188 end;
189
190 { TCustomCheckBoxThemed }
191
192 constructor TCustomCheckBoxThemed.Create(AOwner: TComponent);
193 begin
194 inherited Create(AOwner);
195 AccessibleRole := larCheckBox;
196 ControlStyle := ControlStyle + [csParentBackground, csReplicatable] - [csOpaque]
197 - csMultiClicks - [csClickEvents, csNoStdEvents]; { inherited Click not used }
198 FAlignment := taRightJustify;
199 FAllowGrayed := False;
200 AutoSize := True;
201 TabStop := True;
202 end;
203
204 procedure TCustomCheckBoxThemed.CalculatePreferredSize(var PreferredWidth,
205 PreferredHeight: Integer; WithThemeSpace: Boolean);
206 var aDetails: TThemedElementDetails;
207 aFlags: Cardinal;
208 aTextSize, CheckBoxSize: TSize;
209 begin
210 CheckBoxSize := GetCheckBoxSize(Font.PixelsPerInch);
211 if Caption <> '' then begin
212 aDetails := ThemeServices.GetElementDetails(tbCheckBoxCheckedNormal);
213 aFlags := DT_CENTER + DT_VCENTER;
214 if IsRightToLeft then inc(aFlags, DT_RTLREADING);
215 with ThemeServices.GetTextExtent(Canvas.Handle, aDetails, Caption, aFlags, nil) do begin
216 aTextSize.cx := Right;
217 aTextSize.cy := Bottom;
218 end;
219 PreferredWidth := CheckBoxSize.cx + cIndent + aTextSize.cx + cFocusBorder;
220 PreferredHeight := Math.max(CheckBoxSize.cy, aTextSize.cy + 2 * cFocusBorder);
221 end else begin
222 PreferredWidth := CheckBoxSize.cx;
223 PreferredHeight := CheckBoxSize.cy;
224 end;
225 end;
226
227 procedure TCustomCheckBoxThemed.CMBiDiModeChanged(var Message: TLMessage);
228 begin
229 Invalidate;
230 end;
231
232 procedure TCustomCheckBoxThemed.CMEnabledChanged(var Message: TLMessage);
233 begin
234 if IsEnabled then FCheckBoxHovered := False;
235 inherited CMEnabledChanged(Message);
236 end;
237
238 class procedure TCustomCheckBoxThemed.InitCheckBoxSize;
239 begin
240 with ThemeServices do
241 FThemeCheckBoxSize := GetDetailSize(GetElementDetails(tbCheckBoxCheckedNormal));
242 end;
243
DialogCharnull244 function TCustomCheckBoxThemed.DialogChar(var Message: TLMKey): Boolean;
245 begin
246 Result := False;
247 if Message.Msg = LM_SYSCHAR then begin
248 if IsEnabled and IsVisible then begin
249 if IsAccel(Message.CharCode, Caption) then begin
250 DoClick;
251 SetFocus;
252 Result := True;
253 end else
254 Result := inherited DialogChar(Message);
255 end;
256 end;
257 end;
258
259 procedure TCustomCheckBoxThemed.DoClick;
260 begin
261 if AllowGrayed then begin
262 case FState of
263 cbUnchecked: State := cbGrayed;
264 cbGrayed: State := cbChecked;
265 cbChecked: State := cbUnchecked;
266 end;
267 end else
268 Checked := not Checked;
269 end;
270
271 procedure TCustomCheckBoxThemed.DoEnter;
272 begin
273 inherited DoEnter;
274 Invalidate;
275 end;
276
277 procedure TCustomCheckBoxThemed.DoExit;
278 begin
279 inherited DoExit;
280 Invalidate;
281 end;
282
GetActionLinkClassnull283 function TCustomCheckBoxThemed.GetActionLinkClass: TControlActionLinkClass;
284 begin
285 Result := TCheckBoxThemedActionLink;
286 end;
287
TCustomCheckBoxThemed.GetCheckBoxSizenull288 class function TCustomCheckBoxThemed.GetCheckBoxSize(
289 const PixelsPerInch: Integer): TSize;
290 begin
291 if FThemeCheckBoxSize.cx<=0 then
292 InitCheckBoxSize;
293 Result.cx := MulDiv(FThemeCheckBoxSize.cx, PixelsPerInch, Screen.PixelsPerInch);
294 Result.cy := MulDiv(FThemeCheckBoxSize.cy, PixelsPerInch, Screen.PixelsPerInch);
295 end;
296
297 procedure TCustomCheckBoxThemed.KeyDown(var Key: Word; Shift: TShiftState);
298 begin
299 inherited KeyDown(Key, Shift);
300 if (Key in [VK_RETURN, VK_SPACE]) and not (ssCtrl in Shift) then begin
301 CheckBoxPressed := True;
302 Invalidate;
303 end;
304 end;
305
306 procedure TCustomCheckBoxThemed.KeyUp(var Key: Word; Shift: TShiftState);
307 begin
308 inherited KeyUp(Key, Shift);
309 if (Key in [VK_RETURN, VK_SPACE]) and not (ssCtrl in Shift) then begin
310 CheckBoxPressed := False;
311 DoClick;
312 end;
313 end;
314
315 procedure TCustomCheckBoxThemed.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
316 begin
317 inherited MouseDown(Button, Shift, X, Y);
318 if (Button = mbLeft) and CheckBoxHovered then begin
319 CheckBoxPressed := True;
320 Invalidate;
321 end;
322 SetFocus;
323 end;
324
325 procedure TCustomCheckBoxThemed.MouseEnter;
326 begin
327 inherited MouseEnter;
328 CheckBoxHovered := True;
329 end;
330
331 procedure TCustomCheckBoxThemed.MouseLeave;
332 begin
333 inherited MouseLeave;
334 CheckBoxHovered := False;
335 end;
336
337 procedure TCustomCheckBoxThemed.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
338 begin
339 inherited MouseUp(Button, Shift, X, Y);
340 if Button = mbLeft then begin
341 if PtInRect(ClientRect, Point(X, Y)) then DoClick;
342 CheckBoxPressed := False;
343 end;
344 end;
345
346 class procedure TCustomCheckBoxThemed.PaintSelf(ACanvas: TCanvas;
347 ACaption: string; ARect: TRect; AState: TCheckBoxState; ARightToLeft,
348 AHovered, APressed, AFocused: Boolean; AAlignment: TLeftRight;
349 AEnabled: Boolean);
350 var aCaptionPoint, aCheckBoxPoint: TPoint;
351 aDetails: TThemedElementDetails;
352 aFlags: Cardinal;
353 aHelpRect: TRect;
354 aTextSize, CheckBoxSize: TSize; { Hovered, Pressed, State }
355 const caEnabledDetails: array [False..True, False..True, cbUnchecked..cbGrayed] of TThemedButton =
356 (((tbCheckBoxUncheckedNormal, tbCheckBoxCheckedNormal, tbCheckBoxMixedNormal),
357 (tbCheckBoxUncheckedPressed, tbCheckBoxCheckedPressed, tbCheckBoxMixedPressed)),
358 ((tbCheckBoxUncheckedHot, tbCheckBoxCheckedHot, tbCheckBoxMixedHot),
359 (tbCheckBoxUncheckedPressed, tbCheckBoxCheckedPressed, tbCheckBoxMixedPressed)));
360 const caDisabledDetails: array [cbUnchecked..cbGrayed] of TThemedButton =
361 (tbCheckBoxUncheckedDisabled, tbCheckBoxCheckedDisabled, tbCheckBoxMixedDisabled);
362 begin
363 CheckBoxSize := GetCheckBoxSize(ACanvas.Font.PixelsPerInch);
364 { Calculate }
365 if AEnabled then
366 aDetails := ThemeServices.GetElementDetails(caEnabledDetails[AHovered, False, AState])
367 else
368 aDetails := ThemeServices.GetElementDetails(caDisabledDetails[AState]);
369 if ACaption <> '' then begin
370 aFlags := DT_CENTER + DT_VCENTER;
371 if ARightToLeft then inc(aFlags, DT_RTLREADING);
372 with ThemeServices.GetTextExtent(ACanvas.Handle, aDetails, ACaption, aFlags, nil) do begin
373 aTextSize.cx := Right;
374 aTextSize.cy := Bottom;
375 end;
376 aCaptionPoint.Y := (ARect.Bottom + ARect.Top - aTextSize.cy) div 2;
377 aCheckBoxPoint.Y := (ARect.Bottom + ARect.Top - CheckBoxSize.cy) div 2;
378 if ARightToLeft xor (AAlignment = taLeftJustify) then begin { Caption is on the Left }
379 aCheckBoxPoint.X := ARect.Right - CheckBoxSize.cx;
380 aCaptionPoint.X := ARect.Left;
381 end else begin { Caption is on the Right }
382 aCheckBoxPoint.X := ARect.Left;
383 aCaptionPoint.X := aCheckBoxPoint.X + cIndent + CheckBoxSize.cx;
384 end;
385 end else begin
386 if not ARightToLeft then
387 aCheckBoxPoint.X := ARect.Left
388 else
389 aCheckBoxPoint.X := ARect.Right - CheckBoxSize.cx;
390 aCheckBoxPoint.Y := (ARect.Bottom - CheckBoxSize.cy) div 2;
391 end;
392 { Paint Caption }
393 if ACaption <> '' then begin
394 aHelpRect := Rect(aCaptionPoint.X, aCaptionPoint.Y,
395 aCaptionPoint.X + aTextSize.cx, aCaptionPoint.Y + aTextSize.cy);
396 ThemeServices.DrawText(ACanvas, aDetails, ACaption, aHelpRect, aFlags, 0);
397 { Paint FocusRect around Caption }
398 if AFocused then begin
399 dec(aHelpRect.Left, cFocusBorder);
400 inc(aHelpRect.Right, cFocusBorder);
401 LCLIntf.SetBkColor(ACanvas.Handle, ColorToRGB(clBtnFace));
402 LCLIntf.DrawFocusRect(ACanvas.Handle, aHelpRect);
403 end;
404 end;
405 { Paint CheckBox }
406 if AEnabled then
407 aDetails := ThemeServices.GetElementDetails(caEnabledDetails[AHovered, APressed, AState])
408 else
409 aDetails := ThemeServices.GetElementDetails(caDisabledDetails[AState]);
410 aHelpRect := Rect(aCheckBoxPoint.X, aCheckBoxPoint.Y,
411 aCheckBoxPoint.X + CheckBoxSize.cx, aCheckBoxPoint.Y + CheckBoxSize.cy);
412 ThemeServices.DrawElement(ACanvas.Handle, aDetails, aHelpRect);
413 end;
414
415 procedure TCustomCheckBoxThemed.Paint;
416 begin
417 inherited Paint;
418 PaintSelf(Canvas, Caption, ClientRect, State, IsRightToLeft, CheckBoxHovered,
419 CheckBoxPressed, Focused, Alignment, IsEnabled);
420 end;
421
422 procedure TCustomCheckBoxThemed.TextChanged;
423 begin
424 inherited TextChanged;
425 Invalidate;
426 end;
427
428 procedure TCustomCheckBoxThemed.WMSize(var Message: TLMSize);
429 begin
430 inherited WMSize(Message);
431 Invalidate;
432 end;
433
434 { Setters }
435
TCustomCheckBoxThemed.GetCheckednull436 function TCustomCheckBoxThemed.GetChecked: Boolean;
437 begin
438 Result := (FState = cbChecked);
439 end;
440
441 procedure TCustomCheckBoxThemed.SetAlignment(AValue: TLeftRight);
442 begin
443 if FAlignment = AValue then exit;
444 FAlignment := AValue;
445 Invalidate;
446 end;
447
448 procedure TCustomCheckBoxThemed.SetCheckBoxHovered(AValue: Boolean);
449 begin
450 if FCheckBoxHovered = AValue then exit;
451 FCheckBoxHovered := AValue;
452 Invalidate;
453 end;
454
455 procedure TCustomCheckBoxThemed.SetChecked(AValue: Boolean);
456 begin
457 if AValue then
458 State := cbChecked
459 else
460 State := cbUnChecked;
461 end;
462
463 procedure TCustomCheckBoxThemed.SetState(AValue: TCheckBoxState);
464 begin
465 if FState = AValue then exit;
466 FState := AValue;
467 if [csLoading, csDestroying, csDesigning]*ComponentState = [] then begin
468 if Assigned(OnEditingDone) then OnEditingDone(self);
469 if Assigned(OnChange) then OnChange(self);
470 { Execute only when Action.Checked is changed }
471 if not CheckFromAction then begin
472 if Assigned(OnClick) then
473 if not (Assigned(Action) and
474 CompareMethods(TMethod(Action.OnExecute), TMethod(OnClick)))
475 then OnClick(self);
476 if (Action is TCustomAction) and
477 (TCustomAction(Action).Checked <> (AValue = cbChecked))
478 then ActionLink.Execute(self);
479 end;
480 end;
481 Invalidate;
482 end;
483
484 end.
485
486
487