diff --git a/components/exctrls/examples/CheckCtrlsEx/demo.lpi b/components/exctrls/examples/CheckCtrlsEx/demo.lpi
new file mode 100644
index 000000000..bdbf8ad31
--- /dev/null
+++ b/components/exctrls/examples/CheckCtrlsEx/demo.lpi
@@ -0,0 +1,80 @@
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+ -
+
+
+ -
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+ -
+
+
+ -
+
+
+ -
+
+
+
+
+
diff --git a/components/exctrls/examples/CheckCtrlsEx/demo.lpr b/components/exctrls/examples/CheckCtrlsEx/demo.lpr
new file mode 100644
index 000000000..5e4f6d42b
--- /dev/null
+++ b/components/exctrls/examples/CheckCtrlsEx/demo.lpr
@@ -0,0 +1,25 @@
+program demo;
+
+{$mode objfpc}{$H+}
+
+uses
+ {$IFDEF UNIX}
+ cthreads,
+ {$ENDIF}
+ {$IFDEF HASAMIGA}
+ athreads,
+ {$ENDIF}
+ Interfaces, // this includes the LCL widgetset
+ Forms, main
+ { you can add units after this };
+
+{$R *.res}
+
+begin
+ RequireDerivedFormResource:=True;
+ Application.Scaled:=True;
+ Application.Initialize;
+ Application.CreateForm(TMainForm, MainForm);
+ Application.Run;
+end.
+
diff --git a/components/exctrls/examples/CheckCtrlsEx/main.lfm b/components/exctrls/examples/CheckCtrlsEx/main.lfm
new file mode 100644
index 000000000..4302a978b
--- /dev/null
+++ b/components/exctrls/examples/CheckCtrlsEx/main.lfm
@@ -0,0 +1,314 @@
+object MainForm: TMainForm
+ Left = 353
+ Height = 295
+ Top = 132
+ Width = 735
+ Caption = 'Extended Check Controls Demo'
+ ClientHeight = 295
+ ClientWidth = 735
+ OnCreate = FormCreate
+ LCLVersion = '2.1.0.0'
+ object CheckBoxEx1: TCheckBoxEx
+ AnchorSideLeft.Control = Label1
+ AnchorSideTop.Control = Label1
+ AnchorSideTop.Side = asrBottom
+ Left = 16
+ Height = 19
+ Top = 35
+ Width = 412
+ BorderSpacing.Top = 4
+ Caption = 'Lorem ipsum dolor sit amet, consetetur sadipscing elitr, sed diam nonumy'
+ TabOrder = 0
+ TabStop = True
+ end
+ object Label1: TLabel
+ AnchorSideLeft.Control = Owner
+ AnchorSideTop.Control = Owner
+ Left = 16
+ Height = 15
+ Top = 16
+ Width = 142
+ BorderSpacing.Left = 16
+ BorderSpacing.Top = 16
+ Caption = 'AutoSize + no WordWrap'
+ Font.Style = [fsBold]
+ ParentColor = False
+ ParentFont = False
+ end
+ object Label2: TLabel
+ AnchorSideLeft.Control = CheckBoxEx1
+ AnchorSideTop.Control = CheckBoxEx1
+ AnchorSideTop.Side = asrBottom
+ Left = 16
+ Height = 15
+ Top = 78
+ Width = 125
+ BorderSpacing.Top = 24
+ Caption = 'AutoSize + WordWrap'
+ Font.Style = [fsBold]
+ ParentColor = False
+ ParentFont = False
+ end
+ object CheckBoxEx2: TCheckBoxEx
+ AnchorSideLeft.Control = CheckBoxEx1
+ AnchorSideTop.Control = Label2
+ AnchorSideTop.Side = asrBottom
+ Left = 16
+ Height = 49
+ Top = 97
+ Width = 172
+ BorderSpacing.Top = 4
+ Caption = 'Lorem ipsum dolor sit amet, consetetur sadipscing elitr, sed diam nonumy'
+ TabOrder = 1
+ TabStop = True
+ WordWrap = True
+ end
+ object Label3: TLabel
+ AnchorSideLeft.Control = CheckBoxEx1
+ AnchorSideTop.Control = CheckBoxEx2
+ AnchorSideTop.Side = asrBottom
+ Left = 16
+ Height = 15
+ Top = 170
+ Width = 199
+ BorderSpacing.Top = 24
+ Caption = 'AutoSize + WordWrap + Top Layout'
+ Font.Style = [fsBold]
+ ParentColor = False
+ ParentFont = False
+ end
+ object CheckBoxEx3: TCheckBoxEx
+ AnchorSideLeft.Control = CheckBoxEx1
+ AnchorSideTop.Control = Label3
+ AnchorSideTop.Side = asrBottom
+ Left = 16
+ Height = 49
+ Top = 189
+ Width = 172
+ BorderSpacing.Top = 4
+ ButtonLayout = tlTop
+ Caption = 'Lorem ipsum dolor sit amet, consetetur sadipscing elitr, sed diam nonumy'
+ TabOrder = 2
+ TabStop = True
+ WordWrap = True
+ end
+ object Label4: TLabel
+ AnchorSideTop.Control = Label2
+ Left = 282
+ Height = 15
+ Top = 78
+ Width = 171
+ Caption = 'Item colors by code at runtime'
+ Font.Style = [fsBold]
+ ParentColor = False
+ ParentFont = False
+ end
+ object RadioGroupEx1: TRadioGroupEx
+ AnchorSideLeft.Control = Label4
+ AnchorSideTop.Control = Label4
+ AnchorSideTop.Side = asrBottom
+ Left = 282
+ Height = 105
+ Top = 101
+ Width = 198
+ BorderSpacing.Top = 8
+ Caption = 'RadioGroupEx1'
+ ChildSizing.LeftRightSpacing = 6
+ ChildSizing.EnlargeHorizontal = crsHomogenousChildResize
+ ChildSizing.EnlargeVertical = crsHomogenousChildResize
+ ChildSizing.ShrinkHorizontal = crsScaleChilds
+ ChildSizing.ShrinkVertical = crsScaleChilds
+ ChildSizing.Layout = cclLeftToRightThenTopToBottom
+ ChildSizing.ControlsPerLine = 1
+ ItemIndex = 1
+ Items.Strings = (
+ 'This item is red.'
+ 'The second item is green.'
+ 'The third item is blue.'
+ 'The last item is disabled.'
+ )
+ TabOrder = 3
+ end
+ object Label5: TLabel
+ AnchorSideTop.Control = Label4
+ Left = 536
+ Height = 15
+ Top = 78
+ Width = 159
+ Caption = 'User-provided button glyphs'
+ Font.Style = [fsBold]
+ ParentColor = False
+ ParentFont = False
+ end
+ object RadioButtonEx1: TRadioButtonEx
+ Left = 536
+ Height = 19
+ Top = 108
+ Width = 83
+ Caption = 'First option'
+ Checked = True
+ Images = ImageList1
+ State = cbChecked
+ TabOrder = 4
+ TabStop = True
+ OnGetImageIndex = RadioButtonEx1GetImageIndex
+ end
+ object RadioButtonEx2: TRadioButtonEx
+ Left = 536
+ Height = 19
+ Top = 137
+ Width = 100
+ Caption = 'Second option'
+ Images = ImageList1
+ TabOrder = 5
+ TabStop = True
+ OnGetImageIndex = RadioButtonEx1GetImageIndex
+ end
+ object RadioButtonEx3: TRadioButtonEx
+ Left = 536
+ Height = 19
+ Top = 168
+ Width = 88
+ Caption = 'Third option'
+ Images = ImageList1
+ TabOrder = 6
+ TabStop = True
+ OnGetImageIndex = RadioButtonEx1GetImageIndex
+ end
+ object Label6: TLabel
+ AnchorSideLeft.Control = RadioGroupEx1
+ AnchorSideTop.Control = RadioGroupEx1
+ AnchorSideTop.Side = asrBottom
+ Left = 282
+ Height = 15
+ Top = 214
+ Width = 34
+ BorderSpacing.Top = 8
+ Caption = 'Label6'
+ ParentColor = False
+ end
+ object ImageList1: TImageList
+ Scaled = True
+ left = 496
+ top = 16
+ Bitmap = {
+ 4C7A020000001000000010000000E60300000000000078DA8D935D6C536518C7
+ DF33ED9D3743442643C39041748CB181C292F1D1CE2D6CDD706E6C7183D94264
+ C446091B048D892E5E60480DEB5205D62E5E907061160C423B865AF6413B9833
+ 284847BB6EDE80EB8A4E34125CA1F3EFF3BCDDE9DAD92DBEC92F7DCEF3FC7FEF
+ 7B4E4E8F10094BD9A03DE9341DBE85DDFBBDA837DD44EDBE9FB063CF0D54197F
+ 44F6C6CF9C9C11C917B9271CC76C21ACD0FE22C9D4455959C88CA1CE1440D6CB
+ 9F3A92ECA1ACDF7CDC613E1142567110D92541AC290D22671AAEB9B77ADB38AA
+ 1BFC7861BD357E0F25AFE0B8E3A316CAEA43C8A68CF5D45FF2775D794812EB95
+ 8C23B7FC2EB61B7C58B52EBAC7C27443F3879FDCC14B15BF228F66EEC13078F5
+ 0E84915B7657C2352F9E716643E56F28A9F562D1B3C6E6279718CC6F7F308E82
+ EA096CAC9C4047E7DF50D7A52B6189BA78C6994D3513287A7D947D339D6F36BD
+ 3F0E6DED3D68EBEE21BFEA77CA4D62F6E21ECF38C3B0FFF47351BFE1DD208AEA
+ FF4431C1BFF9957F602C341573B9E69E9A9139D55F6A30BF793088D2DDF72545
+ BBEEE3CAB5C87FCEE71ECF38A3275EA9F959FA4F2D359A8D8D637875EF03EA3F
+ 4870BFEC7A2451977B3022331594D555ABBEE1C84ED30876BC154645C3249CDD
+ 51DFD53F85B23D9392DEABD167E9A41967AA4D61E4EB6FB07F84DEE1E2557916
+ 774DC3086ADF7984CA7D0FD1763A42FB3DA4EB285C73AF8A6675FB232828F722
+ 23FB989BDDE9FF51FACADC16F76BC600DE689AC2AE0311D43726C23D43D33FD8
+ B47D4875D3E3FF837CBD22A7C5ADDFE9C7DEF790942D15495D11BFC7F339164F
+ 9ECE8D5CED65ACDDD287359B7BB1BA204A46768B670E377E0F7EA6AC39583C8F
+ 2BFD4587F5CED2EE5694765B66D10A9ECD77F6C243DB9C65DE4E08A71DC2614B
+ 847A3CE34CB2675F40FD62AF03A28BDCAFDB9373B11DC5430E2C48DC4349A56B
+ EDD05710DF92EB6A9F13CD792B1E3F67C556CAA6AA7B142E6FDEEA3F07D14D6E
+ CFDC280E0BFAEE8CA29750CE5B201D72852EC3BCD64767F7D9A1B9609588CB76
+ 792DA15A715AA4A7AEA3DFB990E327875CE645FF59A474B5CAFD19A5CB02D16F
+ 97701DEF72CDD9ACE1B3313F33700647075C0919E51B8B64B6CB3D316047E6F0
+ 9998BF6CA4032997287B7B26DB737B44127369A6B8C8FD9EDEE5A00DCB021DD3
+ FE72F392D12F207EB041E9493C2FE15C9A71465C8B221D72898F9F193E05719D
+ 9EF73AEDD197781FF25CEAF16C063BA4432EBDC3344D63A127D5F739C44D9B44
+ 71D3BB228FE15AEDAB70961D76D5EFEEB1469DE7091FDD83AF0DE2561B34575B
+ 255CC7A01967389BECFB4F39A0F368FC272102B61986A7A19A679C99EFFB174D
+ 85FD4AE721A4380F26C03D9EFD8FEF3F6D9EEF3F6DB6FB2F39580CCE
+ }
+ BitmapAdv = {
+ 4C69010000004C7A020000002000000020000000430A00000000000078DACD97
+ 795054D915C65F25A19C542A3553339615AD4A659BD1191718371050947D5790
+ 551041C57D1F1DC744333571665CE2246A748406CC188D8995983F26A9718786
+ 6E166D7014DC978C0BB6343474E3C6A6F0E59CFBBAE98547D3A07FE4557DF56E
+ DF7BCEF73BEFDEF76EBF27497D1E1EEFFA96D48FF029C1089F62BC3BA944E83D
+ 5F8BFC4A30D24EA3FC591A8C9E5C52CFB9D2CB1D1EEF4C28D2EFDD7F17855A13
+ 0E1E35E2AB230DC83B6CC09707EAB03BFF21FE90ABC7B63DF7F1E91F6BF1F18E
+ 7BF8F5E777F0C98EFF227B753546FA16EB5FA2068FB789AD3A7017278ACC181E
+ F4003F9BF200BF08204D7D805FB2A6B1F4F8152B508FB703E5F388103DD67D72
+ 1B59CB2FD29C0CA8866E76A1B619A342F5181EACC7C8308BC29535CA727E2FF4
+ 2146853DC4AA4D3791B1E4427F6B1073BE27EF0E4EAA4D1813F150F88D897C08
+ AF28F7E449B1A323EAE85C87A51B6E2075C179776BF07867A25AFFC597B7F1F5
+ C926F2AAA36BAA13674F8BDE8FAEC3D81865F198354ECE31602CF52D587B0D49
+ 5955745FBAACC163B8B75ABF6DD72DFCE36B23F9D5D3351BC8D38051742DDEF1
+ 06216E8F8D3160FC7447719F73DCFB3106E1336E7A3D32575C415C46253D178A
+ 35788C20F6E6DFDFC0A1A3F59830A341E48DA73C4FAAC18BAEA3F971979017FD
+ E6BE0934E61D276B82352ED22E2ECA16C77E1367D4236DF16544A7EAF8D9B4AF
+ C183D6A661D396EB28385C079FB8068CA7786F3A8FE3DA490D8D9DB01E0DC64E
+ 9AD37A9A977A11C3E236F7F158771CE588FCD87AF8C4535CBC1193661A9138B7
+ 066189E7E01950D260A9E18D11B49F1CFD8F1E3E331B3191E27C13E458CFA806
+ 3C7E6AF3B41EF5E43D2196B831B2B85DDFD8338E73D983BDFC12C937B1097E09
+ 4D48C8ACC298295A309B3484F7B6BFFDEB3E26C699E09FD88829C98DE23C2ED6
+ 086D653B940E03F1C64619850C0A6C3E38973DAC9E53929B3039B919F1193AE2
+ 6B983F44F0E9FA0F1EB98749096604A434616AAA2C3FAA774C841185656D8AFE
+ 77F59D424A07E7702E7B58FD5801A98F303DFDACF5FA059FF7F3FC4377E09FD4
+ 8C69B34C084C93C56DFF2413CD61238ACA95E741E9E058CEE15C7BBFC0343302
+ D31FD33D5841EBEFC8DFB7FF3BAAEF1182D3CD08996D13FF0E4831D3F3D084A2
+ 8ABE6BE0188EE51C67AF90D9CD08C97882F024273EFD8FEDCAB945B53D416846
+ 33C2E6388AFBA6A69AE97932E198BAA357368F710CC72AF984CD7984F0ACA708
+ 4D2873E0F3FFE8F6DD37A9BEA708A798884C4785653CC2D49466BA7F9AF1A0EE
+ 45AF7C1EE3188EE51C679F88CCC7889CFB0C41339CF8F4BFFDD917D768BC0551
+ 739F20DA4E91994F109C46F332FB311A9ABAFA9C7F8EE158CEE1DC6807BFA788
+ 9DDF86809852073EBF377CBCE52AB15B11339F636445CF7B4AD7C173F2048DA6
+ 2EB7EF3F8EE51CCE658FD86ECF6798B1B01D7E111A27BE061B7E7709B1D9ED98
+ BE8062487C8ECC7A8628CAEF8D7D4AFB5C48B10673976047653DEBF69CB1A005
+ F18B3BE01D5A02AFA9767C7A5F5ABDB106718B3A3073512BA905710B5B1031A7
+ 050FEBBB7AD95B68AD139F09715BE9B87EBB93D68098E4C59E098B5B91B4EC05
+ C606163BF0F97D6DD987D5485ADA8EC4252CAA8162A3693D74D53DBD4B89179C
+ D682E9D9AD42DC56AAA1B2A6537830973D9397B52365F9736233BFB49B3F7A72
+ 91292EA30AF3565DA7F1768AEBA03ADB10BFA88DD6B015E5E76DDEA666D073DD
+ 4AF3D346F5CAE236CF9BC96C63730EE7CE248F64F24A5DD181D4E534F76195C4
+ D6C02B406DB2F0F93F60E248BF53C6D8341D32975F45DAAA0ECC5AF19CE2692E
+ 16B7D31CB6A1AABA13CF5A40D7D1868445ED626CD60A59DC9EB9A85D8C710CC7
+ 720EE7F278FAAAE7485BF91CDEE13A6297D0DE7BC6C84C0B9BFF038792FCB886
+ C8D473F43F7D0519AB5F209D94B6B20329CBF8BEE8A075EC40F252AA8DFAD257
+ 398AFB788C63383665B9DC9FB1E60566AFE924365D7700B34F33DBCFC2EC7E07
+ B0FCF61DE97FCA189E7816C9F32F61CE079D42196B9E532DB26693F8B79266AF
+ B6C5F1EFCCB59DA42E67B6AF135B72AE6114D5101C5F81F8CC1ACC5DD785791F
+ 76216BED8B7E8973E6AD037C68BD3DFB662BD610105B8698F46A64AF07B23F02
+ E6AFEF724BD91B20727C22FAC556A8E1B4D13FB214E1C917B1F837C0924D0AFA
+ ADACA576E2D801B27BD4307AF269A34F7829FCA80EDF082D268569E013AA8177
+ 4831C6D33E326E9A9AEE693571D418ED5F44EF9645A2CDCFD800D9CE35F8794E
+ 519B79BFEE4DBC97F55080DAAC709F4B03AC819FD52052B09B0AB2E40C7D15DF
+ C0D6F7D47EEA8D57C096F9DBC31BA4AD2190B60643DA12E45A1CC3B19CF32AAE
+ FDF3E0BA59E70F635FDB5DEC6BF90EFB5AFB10C7502CE770EE4BAD3DE52755FD
+ 051F18BE85F4CD7E48FF56B9278AE51CCE1D600D821D5F75002B0D95908E13FB
+ 9B3C48C7F2DD13C7520EE7B2473F6B10ECE9BAAFB0D4A0837482D8C7C9EF6441
+ FFC43994CB1EECE5660D821DADFB33161ACE413A45EC13E473AA60603A497371
+ 5AF662CF3E6A10EC08DD7ECC3554403AC31EF9F279202AB4E80C7BC89EECDD4B
+ 0DC40EA90BD515604E5DB99C739AEEA3C2FC97900A83F76EC25B7B37925FAEE8
+ CB30948319CC72F8EFDF1E6E0CAA2CC0AC3A7A2754D37811CDB93A7F602AE673
+ 2E5EDBF551F7BBD8A05DEBC933478CA712239058CCECDEDBB68662D9637AC68A
+ 2DECE2FC81A984CFB918B47B7D8F7751EEE3BA98B19459C4ECDE5769BFCA7E44
+ F77A91CAE6A321692DD258FAFA9432DB7ABCC96B51AC9259BC475AF76A6A6799
+ E99E2B51C9BC5296BC7E2C6E8B3E6D2F1263B9629E5D1DE25ED0AA90D95CD183
+ 9F6EA6FB4E93277B9539AE1FB7B94F2AB3D666A73239BE2FB6F0E0EBD0E621BD
+ B9DC891F8A44137D0F9411BF42E5C076B8872AA8860AE2955BC4ED8ABED9DDB9
+ 9C438C2466C9EBDFCD8F336928260F6FEDD9E8DAE72CF99CCDB7C84DB635A742
+ E6C7994A7AF0A31AD590742A97FC6EBFCA1C21B7D83A8AD5D1BC9EB3E8AC4A66
+ 39F1431B0B055FAACC559C7FFB43DAB956C8257BA7B5CE3C996FD53995CC72E0
+ 8761AAF114A42A1A3F4FFA3647E40FF4106CF2105E554EA27A048B98F67C3FE3
+ 493B3EE9C2C06A106CCA151EE715440CC172E24F301EA7BC3C9B2E92AAFB5EE3
+ 1EEB4D3922F742EF122C077E38BC1A8E41AA299073ADAA26D5B857836053ACC8
+ B9E842C4102C62DAF1CD43CB77E0E7B547E51AAAF36CAA215D72BD1662CE2946
+ C456BB1079338359CCB4FFFE973687340DD16EC34F6BFF09E932D57029CFA62B
+ 2CE51A049BC644CC2517224FF66606B39CBEFF87896F15EA7F53BB153FA93D02
+ E92AED1597F36C62FFAB39786DA7DDBE4C6DEE1363975D88BCD893BD2D6C3F0B
+ D3F9FB5FD4F0BA760B06D7FE1DD235AAE1AACAA6EBA41B3918FCA74D42DC167D
+ 575D883CD88B3DEDD8AEBEFF450D3FD67E86D7EFD33BFC4DAAFF9ACA26E6DDB4
+ E8BACA71CC5994CB1EECD5075BB1861F6A3EC58FEE1D82748B6AB8A1B2C9CABF
+ E14294C3B9ECE1265BB1060FCD660CAAA5EF88DBB416B7F3E45A5C8963289673
+ 38B79F6C851A429BBEA7DD8CEFEBFF8A1FD41E744B1CCB399CFB12DFE0B61AB6
+ 44344BDB22E43DC31D712CE7BC9AEFFF612FF1FD3FECFFFDFBFF7F3E2F3290
+ }
+ end
+end
diff --git a/components/exctrls/examples/CheckCtrlsEx/main.pas b/components/exctrls/examples/CheckCtrlsEx/main.pas
new file mode 100644
index 000000000..b977486dc
--- /dev/null
+++ b/components/exctrls/examples/CheckCtrlsEx/main.pas
@@ -0,0 +1,73 @@
+unit main;
+
+{$mode objfpc}{$H+}
+
+interface
+
+uses
+ Classes, SysUtils, Forms, Controls, Graphics, Dialogs, StdCtrls, ExtCtrls,
+ ExCheckCtrls;
+
+type
+
+ { TMainForm }
+
+ TMainForm = class(TForm)
+ CheckBoxEx1: TCheckBoxEx;
+ CheckBoxEx2: TCheckBoxEx;
+ CheckBoxEx3: TCheckBoxEx;
+ ImageList1: TImageList;
+ Label1: TLabel;
+ Label2: TLabel;
+ Label3: TLabel;
+ Label4: TLabel;
+ Label5: TLabel;
+ Label6: TLabel;
+ RadioButtonEx1: TRadioButtonEx;
+ RadioButtonEx2: TRadioButtonEx;
+ RadioButtonEx3: TRadioButtonEx;
+ RadioGroupEx1: TRadioGroupEx;
+ procedure CheckBox1Change(Sender: TObject);
+ procedure FormCreate(Sender: TObject);
+ procedure RadioButtonEx1GetImageIndex(Sender: TObject; AHover, APressed,
+ AEnabled: Boolean; AState: TCheckboxState; var AImgIndex: Integer);
+ private
+
+ public
+
+ end;
+
+var
+ MainForm: TMainForm;
+
+implementation
+
+{$R *.lfm}
+
+{ TMainForm }
+
+procedure TMainForm.CheckBox1Change(Sender: TObject);
+begin
+ CheckboxEx1.AutoSize := true;
+end;
+
+procedure TMainForm.FormCreate(Sender: TObject);
+begin
+ RadioGroupEx1.Buttons[0].ThemedCaption := false;
+ RadioGroupEx1.Buttons[1].ThemedCaption := false;
+ RadioGroupEx1.Buttons[2].ThemedCaption := false;
+ RadioGroupEx1.Buttons[0].Font.Color := clRed;
+ RadioGroupEx1.Buttons[1].Font.Color := clGreen;
+ RadioGroupEx1.Buttons[2].Font.Color := clBlue;
+ RadioGroupEx1.Buttons[3].Enabled := false;
+ Label6.Caption := 'This box contains ' + IntToStr(RadioGroupEx1.ButtonCount) + ' buttons';
+end;
+
+procedure TMainForm.RadioButtonEx1GetImageIndex(Sender: TObject; AHover,
+ APressed, AEnabled: Boolean; AState: TCheckboxState; var AImgIndex: Integer);
+begin
+ if AState = cbChecked then AImgIndex := 1 else AImgIndex := 0;
+end;
+
+end.
+
diff --git a/components/exctrls/examples/CurrSpinEditEx/InterestCalc.lpi b/components/exctrls/examples/CurrSpinEditEx/InterestCalc.lpi
new file mode 100644
index 000000000..071c4c0d7
--- /dev/null
+++ b/components/exctrls/examples/CurrSpinEditEx/InterestCalc.lpi
@@ -0,0 +1,83 @@
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+ -
+
+
+ -
+
+
+ -
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+ -
+
+
+ -
+
+
+ -
+
+
+
+
+
diff --git a/components/exctrls/examples/CurrSpinEditEx/InterestCalc.lpr b/components/exctrls/examples/CurrSpinEditEx/InterestCalc.lpr
new file mode 100644
index 000000000..3273c4d36
--- /dev/null
+++ b/components/exctrls/examples/CurrSpinEditEx/InterestCalc.lpr
@@ -0,0 +1,25 @@
+program InterestCalc;
+
+{$mode objfpc}{$H+}
+
+uses
+ {$IFDEF UNIX}
+ cthreads,
+ {$ENDIF}
+ {$IFDEF HASAMIGA}
+ athreads,
+ {$ENDIF}
+ Interfaces, // this includes the LCL widgetset
+ Forms, main, lazcontrols
+ { you can add units after this };
+
+{$R *.res}
+
+begin
+ RequireDerivedFormResource:=True;
+ Application.Scaled:=True;
+ Application.Initialize;
+ Application.CreateForm(TMainForm, MainForm);
+ Application.Run;
+end.
+
diff --git a/components/exctrls/examples/CurrSpinEditEx/main.lfm b/components/exctrls/examples/CurrSpinEditEx/main.lfm
new file mode 100644
index 000000000..1e05f553c
--- /dev/null
+++ b/components/exctrls/examples/CurrSpinEditEx/main.lfm
@@ -0,0 +1,156 @@
+object MainForm: TMainForm
+ Left = 353
+ Height = 223
+ Top = 132
+ Width = 304
+ AutoSize = True
+ BorderStyle = bsSingle
+ Caption = 'Savings calculator'
+ ClientHeight = 223
+ ClientWidth = 304
+ OnCreate = Calculate
+ LCLVersion = '2.1.0.0'
+ object sePayment: TCurrSpinEditEx
+ AnchorSideLeft.Control = Label1
+ AnchorSideLeft.Side = asrBottom
+ Left = 168
+ Height = 23
+ Top = 24
+ Width = 103
+ BorderSpacing.Top = 24
+ BorderSpacing.Right = 24
+ MaxLength = 0
+ TabOrder = 0
+ OnChange = Calculate
+ CurrencyFormat = secfValSpaceCurr
+ CurrencyString = '€'
+ Decimals = 2
+ DecimalSeparator = '.'
+ MaxValue = 0
+ MinValue = 0
+ NegCurrencyFormat = sencfMinusValSpaceCurr
+ NullValue = 0
+ ThousandSeparator = ','
+ Value = 100
+ end
+ object Label1: TLabel
+ AnchorSideLeft.Control = Owner
+ AnchorSideTop.Control = sePayment
+ AnchorSideTop.Side = asrCenter
+ Left = 24
+ Height = 15
+ Top = 28
+ Width = 136
+ BorderSpacing.Left = 24
+ BorderSpacing.Right = 8
+ Caption = 'Amount saved per month'
+ ParentColor = False
+ end
+ object seInterestRate: TFloatSpinEditEx
+ AnchorSideLeft.Control = sePayment
+ Left = 168
+ Height = 23
+ Top = 57
+ Width = 103
+ MaxLength = 0
+ TabOrder = 1
+ OnChange = Calculate
+ Increment = 0.1
+ MinValue = 0
+ NullValue = 0
+ Value = 2
+ end
+ object seYears: TSpinEditEx
+ AnchorSideLeft.Control = sePayment
+ Left = 168
+ Height = 23
+ Top = 88
+ Width = 103
+ MaxLength = 0
+ TabOrder = 2
+ OnChange = Calculate
+ Value = 10
+ end
+ object Label2: TLabel
+ AnchorSideTop.Control = seInterestRate
+ AnchorSideTop.Side = asrCenter
+ AnchorSideRight.Control = seInterestRate
+ Left = 77
+ Height = 15
+ Top = 61
+ Width = 83
+ Anchors = [akTop, akRight]
+ BorderSpacing.Right = 8
+ Caption = 'Interest rate (%)'
+ ParentColor = False
+ end
+ object Label3: TLabel
+ AnchorSideTop.Control = seYears
+ AnchorSideTop.Side = asrCenter
+ AnchorSideRight.Control = seYears
+ Left = 133
+ Height = 15
+ Top = 92
+ Width = 27
+ Anchors = [akTop, akRight]
+ BorderSpacing.Right = 8
+ Caption = 'Years'
+ ParentColor = False
+ end
+ object Bevel1: TBevel
+ AnchorSideLeft.Control = sePayment
+ AnchorSideTop.Control = seYears
+ AnchorSideTop.Side = asrBottom
+ AnchorSideRight.Control = sePayment
+ AnchorSideRight.Side = asrBottom
+ Left = 168
+ Height = 8
+ Top = 123
+ Width = 103
+ Anchors = [akTop, akLeft, akRight]
+ BorderSpacing.Top = 12
+ Shape = bsBottomLine
+ end
+ object seFutureValue: TCurrSpinEditEx
+ AnchorSideLeft.Control = sePayment
+ AnchorSideTop.Control = Bevel1
+ AnchorSideTop.Side = asrBottom
+ Left = 168
+ Height = 23
+ Top = 147
+ Width = 103
+ BorderSpacing.Top = 16
+ BorderSpacing.Bottom = 24
+ Font.Style = [fsBold]
+ MaxLength = 0
+ ParentFont = False
+ ReadOnly = True
+ TabOrder = 3
+ CurrencyFormat = secfValSpaceCurr
+ CurrencyString = '€'
+ Decimals = 2
+ DecimalSeparator = '.'
+ MaxValue = 0
+ MinValue = 0
+ NegCurrencyFormat = sencfMinusValSpaceCurr
+ NullValue = 0
+ ThousandSeparator = ','
+ UpDownVisible = False
+ Value = 0
+ end
+ object Label4: TLabel
+ AnchorSideTop.Control = seFutureValue
+ AnchorSideTop.Side = asrCenter
+ AnchorSideRight.Control = seFutureValue
+ Left = 90
+ Height = 15
+ Top = 151
+ Width = 70
+ Anchors = [akTop, akRight]
+ BorderSpacing.Right = 8
+ Caption = 'Future value'
+ Font.Style = [fsBold]
+ ParentColor = False
+ ParentFont = False
+ end
+end
diff --git a/components/exctrls/examples/CurrSpinEditEx/main.pas b/components/exctrls/examples/CurrSpinEditEx/main.pas
new file mode 100644
index 000000000..e0a08a8db
--- /dev/null
+++ b/components/exctrls/examples/CurrSpinEditEx/main.pas
@@ -0,0 +1,48 @@
+unit main;
+
+{$mode objfpc}{$H+}
+
+interface
+
+uses
+ Classes, SysUtils, Forms, Controls, Graphics, Dialogs, StdCtrls, ExtCtrls,
+ SpinEx, ExEditCtrls;
+
+type
+
+ { TMainForm }
+
+ TMainForm = class(TForm)
+ Bevel1: TBevel;
+ sePayment: TCurrSpinEditEx;
+ seFutureValue: TCurrSpinEditEx;
+ seInterestRate: TFloatSpinEditEx;
+ Label1: TLabel;
+ Label2: TLabel;
+ Label3: TLabel;
+ Label4: TLabel;
+ seYears: TSpinEditEx;
+ procedure Calculate(Sender: TObject);
+ private
+
+ public
+
+ end;
+
+var
+ MainForm: TMainForm;
+
+implementation
+
+{$R *.lfm}
+
+uses
+ Math;
+
+procedure TMainForm.Calculate(Sender: TObject);
+begin
+ seFutureValue.Value := -FutureValue(seInterestRate.Value/100, seYears.Value, sePayment.Value*12, 0.0, ptEndOfPeriod);
+end;
+
+end.
+
diff --git a/components/exctrls/exctrlspkg.lpk b/components/exctrls/exctrlspkg.lpk
new file mode 100644
index 000000000..58d5c9e3f
--- /dev/null
+++ b/components/exctrls/exctrlspkg.lpk
@@ -0,0 +1,51 @@
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
diff --git a/components/exctrls/exctrlspkg.pas b/components/exctrls/exctrlspkg.pas
new file mode 100644
index 000000000..403753cc9
--- /dev/null
+++ b/components/exctrls/exctrlspkg.pas
@@ -0,0 +1,22 @@
+{ This file was automatically created by Lazarus. Do not edit!
+ This source is only used to compile and install the package.
+ }
+
+unit ExCtrlsPkg;
+
+{$warn 5023 off : no warning about unused units}
+interface
+
+uses
+ ExCheckCtrls, ExEditCtrls, ExCtrlsReg, LazarusPackageIntf;
+
+implementation
+
+procedure Register;
+begin
+ RegisterUnit('ExCtrlsReg', @ExCtrlsReg.Register);
+end;
+
+initialization
+ RegisterPackage('ExCtrlsPkg', @Register);
+end.
diff --git a/components/exctrls/images/imagelist.txt b/components/exctrls/images/imagelist.txt
new file mode 100644
index 000000000..7d6b03466
--- /dev/null
+++ b/components/exctrls/images/imagelist.txt
@@ -0,0 +1,15 @@
+tradiobuttonex.png
+tradiobuttonex_150.png
+tradiobuttonex_200.png
+tcheckboxex.png
+tcheckboxex_150.png
+tcheckboxex_200.png
+tradiogroupex.png
+tradiogroupex_150.png
+tradiogroupex_200.png
+tcheckgroupex.png
+tcheckgroupex_150.png
+tcheckgroupex_200.png
+tcurrspineditex.png
+tcurrspineditex_150.png
+tcurrspineditex_200.png
diff --git a/components/exctrls/images/make_res.bat b/components/exctrls/images/make_res.bat
new file mode 100644
index 000000000..8167e3d7e
--- /dev/null
+++ b/components/exctrls/images/make_res.bat
@@ -0,0 +1 @@
+lazres ..\source\exctrlsreg.res @imagelist.txt
\ No newline at end of file
diff --git a/components/exctrls/images/tcheckboxex.png b/components/exctrls/images/tcheckboxex.png
new file mode 100644
index 000000000..a98b887be
Binary files /dev/null and b/components/exctrls/images/tcheckboxex.png differ
diff --git a/components/exctrls/images/tcheckboxex_150.png b/components/exctrls/images/tcheckboxex_150.png
new file mode 100644
index 000000000..f64735a36
Binary files /dev/null and b/components/exctrls/images/tcheckboxex_150.png differ
diff --git a/components/exctrls/images/tcheckboxex_200.png b/components/exctrls/images/tcheckboxex_200.png
new file mode 100644
index 000000000..063f09a56
Binary files /dev/null and b/components/exctrls/images/tcheckboxex_200.png differ
diff --git a/components/exctrls/images/tcheckgroupex.png b/components/exctrls/images/tcheckgroupex.png
new file mode 100644
index 000000000..dcdce6034
Binary files /dev/null and b/components/exctrls/images/tcheckgroupex.png differ
diff --git a/components/exctrls/images/tcheckgroupex_150.png b/components/exctrls/images/tcheckgroupex_150.png
new file mode 100644
index 000000000..8debb3186
Binary files /dev/null and b/components/exctrls/images/tcheckgroupex_150.png differ
diff --git a/components/exctrls/images/tcheckgroupex_200.png b/components/exctrls/images/tcheckgroupex_200.png
new file mode 100644
index 000000000..171f10351
Binary files /dev/null and b/components/exctrls/images/tcheckgroupex_200.png differ
diff --git a/components/exctrls/images/tcurrspineditex.png b/components/exctrls/images/tcurrspineditex.png
new file mode 100644
index 000000000..d3e94d42a
Binary files /dev/null and b/components/exctrls/images/tcurrspineditex.png differ
diff --git a/components/exctrls/images/tcurrspineditex_150.png b/components/exctrls/images/tcurrspineditex_150.png
new file mode 100644
index 000000000..c89b405d0
Binary files /dev/null and b/components/exctrls/images/tcurrspineditex_150.png differ
diff --git a/components/exctrls/images/tcurrspineditex_200.png b/components/exctrls/images/tcurrspineditex_200.png
new file mode 100644
index 000000000..286e2eefe
Binary files /dev/null and b/components/exctrls/images/tcurrspineditex_200.png differ
diff --git a/components/exctrls/images/tradiobuttonex.png b/components/exctrls/images/tradiobuttonex.png
new file mode 100644
index 000000000..440e001cf
Binary files /dev/null and b/components/exctrls/images/tradiobuttonex.png differ
diff --git a/components/exctrls/images/tradiobuttonex_150.png b/components/exctrls/images/tradiobuttonex_150.png
new file mode 100644
index 000000000..046461b24
Binary files /dev/null and b/components/exctrls/images/tradiobuttonex_150.png differ
diff --git a/components/exctrls/images/tradiobuttonex_200.png b/components/exctrls/images/tradiobuttonex_200.png
new file mode 100644
index 000000000..40795d3f0
Binary files /dev/null and b/components/exctrls/images/tradiobuttonex_200.png differ
diff --git a/components/exctrls/images/tradiogroupex.png b/components/exctrls/images/tradiogroupex.png
new file mode 100644
index 000000000..696a2d8a8
Binary files /dev/null and b/components/exctrls/images/tradiogroupex.png differ
diff --git a/components/exctrls/images/tradiogroupex_150.png b/components/exctrls/images/tradiogroupex_150.png
new file mode 100644
index 000000000..651b7456b
Binary files /dev/null and b/components/exctrls/images/tradiogroupex_150.png differ
diff --git a/components/exctrls/images/tradiogroupex_200.png b/components/exctrls/images/tradiogroupex_200.png
new file mode 100644
index 000000000..1081a1d7c
Binary files /dev/null and b/components/exctrls/images/tradiogroupex_200.png differ
diff --git a/components/exctrls/source/checkctrlsreg.res b/components/exctrls/source/checkctrlsreg.res
new file mode 100644
index 000000000..a2679ce11
Binary files /dev/null and b/components/exctrls/source/checkctrlsreg.res differ
diff --git a/components/exctrls/source/excheckctrls.pas b/components/exctrls/source/excheckctrls.pas
new file mode 100644
index 000000000..0a7b06aa4
--- /dev/null
+++ b/components/exctrls/source/excheckctrls.pas
@@ -0,0 +1,2177 @@
+{ Extended checked controls (radiobutton, checkbox, radiogroup, checkgroup)
+
+ Copyright (C) 2020 Lazarus team
+
+ This library is free software; you can redistribute it and/or modify it
+ under the same terms as the Lazarus Component Library (LCL)
+
+ See the file COPYING.modifiedLGPL.txt, included in the Lazarus distribution,
+ for details about the license.
+
+}
+
+unit ExCheckCtrls;
+
+{$mode objfpc}{$H+}
+
+interface
+
+uses
+ LCLType, LCLIntf, LCLProc, LMessages,
+ Graphics, Classes, SysUtils, Types, Themes, Controls,
+ StdCtrls, ExtCtrls, ImgList;
+
+type
+ TGetImageIndexEvent = procedure (Sender: TObject; AHover, APressed, AEnabled: Boolean;
+ AState: TCheckboxState; var AImgIndex: Integer) of object;
+
+ { TCustomCheckControlEx }
+
+ TCustomCheckControlEx = class(TCustomControl)
+ private
+ type
+ TCheckControlKind = (cckCheckbox, cckRadioButton);
+ private
+ FAlignment: TLeftRight;
+ FAllowGrayed: Boolean;
+ FThemedBtnSize: TSize;
+ FBtnLayout: TTextLayout;
+ FDistance: Integer; // between button and caption
+ FDrawFocusRect: Boolean;
+ FFocusBorder: Integer;
+ FGroupLock: Integer;
+ FHover: Boolean;
+ FImages: TCustomImageList;
+ FImagesWidth: Integer;
+ FKind: TCheckControlKind;
+ FPressed: Boolean;
+ FReadOnly: Boolean;
+ FState: TCheckBoxState;
+ FTextLayout: TTextLayout;
+ FThemedCaption: Boolean;
+// FTransparent: Boolean;
+ FWordWrap: Boolean;
+ FOnChange: TNotifyEvent;
+ FOnGetImageIndex: TGetImageIndexEvent;
+ function GetCaption: TCaption;
+ function GetChecked: Boolean;
+ procedure SetAlignment(const AValue: TLeftRight);
+ procedure SetBtnLayout(const AValue: TTextLayout);
+ procedure SetCaption(const AValue: TCaption);
+ procedure SetChecked(const AValue: Boolean);
+ procedure SetDrawFocusRect(const AValue: Boolean);
+ procedure SetImages(const AValue: TCustomImageList);
+ procedure SetImagesWidth(const AValue: Integer);
+ procedure SetState(const AValue: TCheckBoxState);
+ procedure SetTextLayout(const AValue: TTextLayout);
+ procedure SetThemedCaption(const AValue: Boolean);
+ //procedure SetTransparent(const AValue: Boolean);
+ procedure SetWordWrap(const AValue: Boolean);
+
+ protected
+ procedure AfterSetState; virtual;
+ procedure CalculatePreferredSize(var PreferredWidth, PreferredHeight: Integer;
+ {%H-}WithThemeSpace: Boolean); override;
+ procedure CMBiDiModeChanged(var {%H-}Message: TLMessage); message CM_BIDIMODECHANGED;
+ procedure CreateHandle; override;
+ procedure DoAutoAdjustLayout(const AMode: TLayoutAdjustmentPolicy;
+ const AXProportion, AYProportion: Double); override;
+ procedure DoClick;
+ procedure DoEnter; override;
+ procedure DoExit; override;
+ procedure DrawBackground;
+ procedure DrawButton(AHovered, APressed, AEnabled: Boolean; AState: TCheckboxState);
+ procedure DrawButtonText(AHovered, APressed, AEnabled: Boolean;
+ AState: TCheckboxState);
+ function GetBtnSize: TSize; virtual;
+ function GetDrawTextFlags: Cardinal;
+ function GetTextExtent(const ACaption: String): TSize;
+ function GetThemedButtonDetails(AHovered, APressed, AEnabled: Boolean;
+ AState: TCheckboxState): TThemedElementDetails; virtual; abstract;
+// procedure InitBtnSize(Scaled: Boolean);
+ procedure LockGroup;
+ procedure KeyDown(var Key: Word; Shift: TShiftState); override;
+ procedure KeyUp(var Key: Word; Shift: TShiftState); override;
+ procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
+ procedure MouseEnter; override;
+ procedure MouseLeave; override;
+ procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
+ procedure Paint; override;
+ procedure TextChanged; override;
+ procedure UnlockGroup;
+ procedure WMSize(var Message: TLMSize); message LM_SIZE;
+
+ property Alignment: TLeftRight read FAlignment write SetAlignment default taRightJustify;
+ property AllowGrayed: Boolean read FAllowGrayed write FAllowGrayed default False;
+ property ButtonLayout: TTextLayout read FBtnLayout write SetBtnLayout default tlCenter;
+ property Caption: TCaption read GetCaption write SetCaption;
+ property Checked: Boolean read GetChecked write SetChecked default false;
+ property DrawFocusRect: Boolean read FDrawFocusRect write SetDrawFocusRect default true;
+ property Images: TCustomImageList read FImages write SetImages;
+ property ImagesWidth: Integer read FImagesWidth write SetImagesWidth default 0;
+ property ReadOnly: Boolean read FReadOnly write FReadOnly default false;
+ property State: TCheckBoxState read FState write SetState default cbUnchecked;
+ property TextLayout: TTextLayout read FTextLayout write SetTextLayout default tlCenter;
+ property ThemedCaption: Boolean read FThemedCaption write SetThemedCaption default true;
+ //property Transparent: Boolean read FTransparent write SetTransparent default true;
+ property WordWrap: Boolean read FWordWrap write SetWordWrap default false;
+ property OnChange: TNotifyEvent read FOnChange write FOnChange;
+ property OnGetImageIndex: TGetImageIndexEvent read FOnGetImageIndex write FOnGetImageIndex;
+
+ public
+ constructor Create(AOwner: TComponent); override;
+
+ end;
+
+ { TCustomCheckboxEx }
+
+ TCustomCheckboxEx = class(TCustomCheckControlEx)
+ private
+ protected
+ function GetThemedButtonDetails(AHovered, APressed, AEnabled: Boolean;
+ AState: TCheckboxState): TThemedElementDetails; override;
+ public
+ constructor Create(AOwner: TComponent); override;
+ end;
+
+
+{ TCheckBoxEx }
+
+ TCheckBoxEx = class(TCustomCheckBoxEx)
+ published
+ //property Action;
+ property Align;
+ property Alignment;
+ property AllowGrayed;
+ property Anchors;
+ property AutoSize default true;
+ property BiDiMode;
+ property BorderSpacing;
+ property ButtonLayout;
+ property Caption;
+ property Checked;
+ property Color;
+ property Constraints;
+ property Cursor;
+ property DoubleBuffered;
+ property DragCursor;
+ property DragKind;
+ property DragMode;
+ property DrawFocusRect;
+ property Enabled;
+ property Font;
+ property Height;
+ property HelpContext;
+ property HelpKeyword;
+ property HelpType;
+ property Hint;
+ property Images;
+ property ImagesWidth;
+ property Left;
+ property Name;
+ property ParentBiDiMode;
+ property ParentColor;
+ property ParentDoubleBuffered;
+ property ParentFont;
+ property ParentShowHint;
+ property ReadOnly;
+ property ShowHint;
+ property State;
+ property TabOrder;
+ property TabStop;
+ property Tag;
+ property TextLayout;
+ property ThemedCaption;
+ property Top;
+ //property Transparent;
+ property Visible;
+ property Width;
+ property WordWrap;
+ property OnChange;
+ property OnChangeBounds;
+ property OnClick;
+ property OnContextPopup;
+ property OnDragDrop;
+ property OnDragOver;
+ property OnEditingDone;
+ property OnEndDrag;
+ property OnEnter;
+ property OnExit;
+ property OnGetImageIndex;
+ property OnKeyDown;
+ property OnKeyPress;
+ property OnKeyUp;
+ property OnMouseDown;
+ property OnMouseEnter;
+ property OnMouseLeave;
+ property OnMouseUp;
+ property OnMouseWheel;
+ property OnMouseWheelDown;
+ property OnMouseWheelUp;
+ property OnResize;
+ property OnStartDrag;
+ property OnUTF8KeyPress;
+ end;
+
+ { TCustomRadioButtonEx }
+
+ TCustomRadioButtonEx = class(TCustomCheckControlEx)
+ protected
+ procedure AfterSetState; override;
+ function GetThemedButtonDetails(AHovered, APressed, AEnabled: Boolean;
+ AState: TCheckboxState): TThemedElementDetails; override;
+ public
+ constructor Create(AOwner: TComponent); override;
+ published
+ end;
+
+ { TRadioButtonEx }
+
+ TRadioButtonEx = class(TCustomRadioButtonEx)
+ published
+ property Align;
+ property Alignment;
+ property Anchors;
+ property AutoSize default true;
+ property BiDiMode;
+ property BorderSpacing;
+ property ButtonLayout;
+ property Caption;
+ property Checked;
+ property Color;
+ property Constraints;
+ property Cursor;
+ property DoubleBuffered;
+ property DragCursor;
+ property DragKind;
+ property DragMode;
+ property DrawFocusRect;
+ property Enabled;
+ property Font;
+ property Height;
+ property HelpContext;
+ property HelpKeyword;
+ property HelpType;
+ property Hint;
+ property Images;
+ property ImagesWidth;
+ property Left;
+ property Name;
+ property ParentBiDiMode;
+ property ParentColor;
+ property ParentDoubleBuffered;
+ property ParentFont;
+ property ParentShowHint;
+ property PopupMenu;
+ property ReadOnly;
+ property ShowHint;
+ property State;
+ property TabOrder;
+ property TabStop;
+ property Tag;
+ property TextLayout;
+ property ThemedCaption;
+ //property Transparent;
+ property Visible;
+ property WordWrap;
+ property Width;
+
+ property OnChange;
+ property OnChangeBounds;
+ property OnClick;
+ property OnContextPopup;
+ property OnDragDrop;
+ property OnDragOver;
+ property OnEnter;
+ property OnExit;
+ property OnKeyDown;
+ property OnKeyPress;
+ property OnKeyUp;
+ property OnMouseDown;
+ property OnMouseEnter;
+ property OnMouseLeave;
+ property OnMouseUp;
+ property OnMouseWheel;
+ property OnMouseWheelDown;
+ property OnMouseWheelUp;
+ property OnResize;
+ property OnStartDrag;
+ property OnGetImageIndex;
+ end;
+
+
+{ TCustomCheckControlGroupEx }
+
+ TCustomCheckControlGroupEx = class(TCustomGroupBox)
+ private
+ FAutoFill: Boolean;
+ FButtonList: TFPList;
+ FColumnLayout: TColumnLayout;
+ FColumns: integer;
+ FImages: TCustomImageList;
+ FImagesWidth: Integer;
+ FItems: TStrings;
+ FIgnoreClicks: boolean;
+ FReadOnly: Boolean;
+ FUpdatingItems: Boolean;
+ FOnClick: TNotifyEvent;
+ FOnGetImageIndex: TGetImageIndexEvent;
+ FOnSelectionChanged: TNotifyEvent;
+ procedure ItemEnter(Sender: TObject);
+ procedure ItemExit(Sender: TObject);
+ procedure ItemKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState); virtual;
+ procedure ItemKeyUp(Sender: TObject; var Key: Word; Shift: TShiftState); virtual;
+ procedure ItemKeyPress(Sender: TObject; var Key: Char); virtual;
+ procedure ItemUTF8KeyPress(Sender: TObject; var UTF8Key: TUTF8Char); virtual;
+ procedure ItemResize(Sender: TObject);
+ procedure SetAutoFill(const AValue: Boolean);
+ procedure SetColumnLayout(const AValue: TColumnLayout);
+ procedure SetColumns(const AValue: integer);
+ procedure SetImages(const AValue: TCustomImageList);
+ procedure SetImagesWidth(const AValue: Integer);
+ procedure SetItems(const AValue: TStrings);
+ procedure SetOnGetImageIndex(const AValue: TGetImageIndexEvent);
+ procedure SetReadOnly(const AValue: Boolean);
+ protected
+ procedure UpdateAll;
+ procedure UpdateControlsPerLine;
+ procedure UpdateInternalObjectList;
+ procedure UpdateItems; virtual; abstract;
+ procedure UpdateTabStops;
+ property AutoFill: Boolean read FAutoFill write SetAutoFill default true;
+ property ColumnLayout: TColumnLayout read FColumnLayout write SetColumnLayout default clHorizontalThenVertical;
+ property Columns: Integer read FColumns write SetColumns default 1;
+ property Images: TCustomImageList read FImages write SetImages;
+ property ImagesWidth: Integer read FImagesWidth write SetImagesWidth default 0;
+ property Items: TStrings read FItems write SetItems;
+ property ReadOnly: Boolean read FReadOnly write SetReadOnly default false;
+ property OnClick: TNotifyEvent read FOnClick write FOnClick;
+ property OnGetImageIndex: TGetImageIndexEvent read FOnGetImageIndex write SetOnGetImageIndex;
+ property OnSelectionChanged: TNotifyEvent read FOnSelectionChanged write FOnSelectionChanged;
+ public
+ constructor Create(AOwner: TComponent); override;
+ destructor Destroy; override;
+ function CanModify: boolean; virtual;
+ procedure FlipChildren(AllLevels: Boolean); override;
+ function Rows: integer;
+ end;
+
+ { TCustomRadioGroupEx }
+ TCustomRadioGroupEx = class(TCustomCheckControlGroupEx)
+ private
+ FCreatingWnd: Boolean;
+ FHiddenButton: TRadioButtonEx;
+ FItemIndex: integer;
+ FLastClickedItemIndex: Integer;
+ FReading: Boolean;
+ procedure Changed(Sender: TObject);
+ procedure Clicked(Sender: TObject);
+ function GetButtonCount: Integer;
+ function GetButtons(AIndex: Integer): TRadioButtonEx;
+ procedure SetItemIndex(const AValue: Integer);
+ protected
+ procedure CheckItemIndexChanged; virtual;
+ procedure InitializeWnd; override;
+ procedure ItemKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState); override;
+ procedure ReadState(AReader: TReader); override;
+ procedure UpdateItems; override;
+ procedure UpdateRadioButtonStates; virtual;
+ property ItemIndex: Integer read FItemIndex write SetItemIndex default -1;
+ public
+ property ButtonCount: Integer read GetButtonCount;
+ property Buttons[AIndex: Integer]: TRadioButtonEx read GetButtons;
+ published
+ constructor Create(AOwner: TComponent); override;
+ end;
+
+ { TRadioGroupEx }
+ TRadioGroupEx = class(TCustomRadioGroupEx)
+ published
+ property Align;
+ property Anchors;
+ property AutoFill;
+ property AutoSize;
+ property BiDiMode;
+ property BorderSpacing;
+ property Caption;
+ property ChildSizing;
+ property Color;
+ property ColumnLayout;
+ property Columns;
+ property Constraints;
+ property Cursor;
+ property DoubleBuffered;
+ property DragCursor;
+ property DragMode;
+ property Enabled;
+ property Font;
+ property Height;
+ property HelpContext;
+ property HelpKeyword;
+ property HelpType;
+ property Hint;
+ property Images;
+ property ImagesWidth;
+ property ItemIndex;
+ property Items;
+ property Left;
+ property Name;
+ property ParentBiDiMode;
+ property ParentColor;
+ property ParentFont;
+ property ParentShowHint;
+ property PopupMenu;
+ property ReadOnly;
+ property ShowHint;
+ property TabOrder;
+ property TabStop;
+ property Tag;
+ property Top;
+ property Visible;
+ property Width;
+ property OnChangeBounds;
+ property OnClick;
+ property OnDblClick;
+ property OnDragDrop;
+ property OnDragOver;
+ property OnEndDrag;
+ property OnEnter;
+ property OnExit;
+ property OnGetImageIndex;
+ property OnKeyDown;
+ property OnKeyPress;
+ property OnKeyUp;
+ property OnMouseDown;
+ property OnMouseEnter;
+ property OnMouseLeave;
+ property OnMouseUp;
+ property OnMouseWheel;
+ property OnMouseWheelDown;
+ property OnMouseWheelUp;
+ property OnResize;
+ property OnSelectionChanged;
+ property OnStartDrag;
+ property OnUTF8KeyPress;
+ end;
+
+ TCustomCheckGroupEx = class(TCustomCheckControlGroupEx)
+ private
+ FOnItemClick: TCheckGroupClicked;
+ procedure Clicked(Sender: TObject);
+ procedure DoClick(AIndex: integer);
+ function GetButtonCount: Integer;
+ function GetButtons(AIndex: Integer): TCheckBoxEx;
+ function GetChecked(AIndex: integer): boolean;
+ function GetCheckEnabled(AIndex: integer): boolean;
+ procedure RaiseIndexOutOfBounds(AIndex: integer);
+ procedure SetChecked(AIndex: integer; const AValue: boolean);
+ procedure SetCheckEnabled(AIndex: integer; const AValue: boolean);
+ protected
+ procedure DefineProperties(Filer: TFiler); override;
+ procedure Loaded; override;
+ procedure ReadData(Stream: TStream);
+ procedure UpdateItems; override;
+ procedure WriteData(Stream: TStream);
+// procedure DoOnResize; override;
+ public
+ constructor Create(AOwner: TComponent); override;
+ property ButtonCount: Integer read GetButtonCount;
+ property Buttons[AIndex: Integer]: TCheckBoxEx read GetButtons;
+ public
+ property Checked[Index: integer]: boolean read GetChecked write SetChecked;
+ property CheckEnabled[Index: integer]: boolean read GetCheckEnabled write SetCheckEnabled;
+ property OnItemClick: TCheckGroupClicked read FOnItemClick write FOnItemClick;
+ end;
+
+ { TCheckGroupEx }
+
+ TCheckGroupEx = class(TCustomCheckGroupEx)
+ published
+ property Align;
+ property Anchors;
+ property AutoFill;
+ property AutoSize;
+ property BiDiMode;
+ property BorderSpacing;
+ property Caption;
+ property ChildSizing;
+ property ClientHeight;
+ property ClientWidth;
+ property Color;
+ property ColumnLayout;
+ property Columns;
+ property Constraints;
+ property DoubleBuffered;
+ property DragCursor;
+ property DragMode;
+ property Enabled;
+ property Font;
+ property Images;
+ property ImagesWidth;
+ property Items;
+ property ParentBiDiMode;
+ property ParentFont;
+ property ParentColor;
+ property ParentDoubleBuffered;
+ property ParentShowHint;
+ property PopupMenu;
+ property ReadOnly;
+ property ShowHint;
+ property TabOrder;
+ property TabStop;
+ property Visible;
+
+ property OnChangeBounds;
+ property OnClick;
+ property OnDblClick;
+ property OnDragDrop;
+ property OnDragOver;
+ property OnEndDrag;
+ property OnEnter;
+ property OnExit;
+ property OnGetImageIndex;
+ property OnItemClick;
+ property OnKeyDown;
+ property OnKeyPress;
+ property OnKeyUp;
+ property OnMouseDown;
+ property OnMouseEnter;
+ property OnMouseLeave;
+ property OnMouseMove;
+ property OnMouseUp;
+ property OnMouseWheel;
+ property OnMouseWheelDown;
+ property OnMouseWheelUp;
+ property OnResize;
+ property OnStartDrag;
+ property OnUTF8KeyPress;
+ end;
+
+implementation
+
+uses
+ Math, LCLStrConsts, LResources;
+
+const
+ cIndent = 5;
+
+ FIRST_RADIOBUTTON_DETAIL = tbRadioButtonUncheckedNormal;
+ FIRST_CHECKBOX_DETAIL = tbCheckBoxUncheckedNormal;
+ HOT_OFFSET = 1;
+ PRESSED_OFFSET = 2;
+ DISABLED_OFFSET = 3;
+ CHECKED_OFFSET = 4;
+ MIXED_OFFSET = 8;
+
+procedure DrawParentImage(Control: TControl; Dest: TCanvas);
+var
+ SaveIndex: integer;
+ DC: HDC;
+ Position: TPoint;
+begin
+ with Control do
+ begin
+ if Parent = nil then Exit;
+ DC := Dest.Handle;
+ SaveIndex := SaveDC(DC);
+ GetViewportOrgEx(DC, @Position);
+ SetViewportOrgEx(DC, Position.X - Left, Position.Y - Top, nil);
+ IntersectClipRect(DC, 0, 0, Parent.ClientWidth, Parent.ClientHeight);
+ Parent.Perform(LM_ERASEBKGND, DC, 0);
+ Parent.Perform(LM_PAINT, DC, 0);
+ RestoreDC(DC, SaveIndex);
+ end;
+end;
+
+function ProcessLineBreaks(const AString: string; ToC: Boolean): String;
+var
+ idx: Integer;
+
+ procedure AddChar(ch: Char);
+ begin
+ Result[idx] := ch;
+ inc(idx);
+ if idx > Length(Result) then
+ SetLength(Result, Length(Result) + 100);
+ end;
+
+var
+ P, PEnd: PChar;
+begin
+ if AString = '' then
+ begin
+ Result := '';
+ exit;
+ end;
+
+ SetLength(Result, Length(AString));
+ idx := 1;
+ P := @AString[1];
+ PEnd := P + Length(AString);
+
+ if ToC then
+ // Replace line breaks by '\n'
+ while P < PEnd do begin
+ if (P^ = #13) then begin
+ AddChar('\');
+ AddChar('n');
+ inc(P);
+ if P^ <> #10 then dec(P);
+ end else
+ if P^ = #10 then
+ begin
+ AddChar('\');
+ AddChar('n');
+ end else
+ if P^ = '\' then
+ begin
+ AddChar('\');
+ AddChar('\');
+ end else
+ AddChar(P^);
+ inc(P);
+ end
+ else
+ // Replace '\n' by LineEnding
+ while (P < PEnd) do
+ begin
+ if (P^ = '\') and (P < PEnd-1) then
+ begin
+ inc(P);
+ if (P^ = 'n') or (P^ = 'N') then
+ AddChar(#10)
+ else
+ AddChar(P^);
+ end else
+ AddChar(P^);
+ inc(P);
+ end;
+ SetLength(Result, idx-1);
+end;
+
+{ TCheckboxControlEx }
+
+constructor TCustomCheckControlEx.Create(AOwner: TComponent);
+begin
+ inherited;
+ ControlStyle := ControlStyle + [csParentBackground, csReplicatable] - [csOpaque]
+ - csMultiClicks - [csClickEvents, csNoStdEvents]; { inherited Click not used }
+
+ FAlignment := taRightJustify;
+ FBtnLayout := tlCenter;
+ FDrawFocusRect := true;
+ FKind := cckCheckbox;
+ FDistance := cIndent;
+ FFocusBorder := FDistance div 2;
+ FTextLayout := tlCenter;
+ FThemedCaption := true;
+// FTransparent := true;
+
+ AutoSize := true;
+ TabStop := true;
+end;
+
+// Is called after the State has changed in SetState. Will be overridden by
+// TCustomRadioButtonEx to uncheck all other iteme.s
+procedure TCustomCheckControlEx.AfterSetState;
+begin
+end;
+
+procedure TCustomCheckControlEx.CalculatePreferredSize(var PreferredWidth,
+ PreferredHeight: Integer; WithThemeSpace: Boolean);
+var
+ flags: Cardinal;
+ textSize: TSize;
+ R: TRect;
+ captn: String;
+ details: TThemedElementDetails;
+ btnSize: TSize;
+begin
+ captn := inherited Caption;
+ if (captn = '') then
+ begin
+ btnSize := GetBtnSize;
+ PreferredWidth := btnSize.CX;
+ PreferredHeight := btnSize.CY;
+ exit;
+ end;
+
+ Canvas.Font.Assign(Font);
+
+ R := ClientRect;
+ btnSize := GetBtnSize;
+ dec(R.Right, btnSize.CX + FDistance);
+ R.Bottom := MaxInt; // Max height possible
+
+ flags := GetDrawTextFlags + DT_CALCRECT;
+
+ // rectangle available for text
+ if FThemedCaption then
+ begin
+ details := GetThemedButtonDetails(false, false, true, cbChecked);
+ if FWordWrap then
+ begin
+ with ThemeServices.GetTextExtent(Canvas.Handle, details, captn, flags, @R) do begin
+ textSize.CX := Right;
+ textSize.CY := Bottom;
+ end;
+ end else
+ with ThemeServices.GetTextExtent(Canvas.Handle, details, captn, flags, nil) do begin
+ textSize.CX := Right;
+ textSize.CY := Bottom;
+ end;
+ end else
+ begin
+ DrawText(Canvas.Handle, PChar(captn), Length(captn), R, flags);
+ textSize.CX := R.Right - R.Left;
+ textSize.CY := R.Bottom - R.Top;
+ end;
+
+ PreferredWidth := btnSize.CX + FDistance + textSize.CX + FFocusBorder;
+ PreferredHeight := Max(btnSize.CY, textSize.CY + 2*FFocusBorder);
+end;
+
+procedure TCustomCheckControlEx.CMBiDiModeChanged(var Message: TLMessage);
+begin
+ Invalidate;
+end;
+
+procedure TCustomCheckControlEx.CreateHandle;
+var
+ w, h: Integer;
+begin
+ inherited;
+ if (Width = 0) or (Height = 0) then begin
+ CalculatePreferredSize(w{%H-}, h{%H-}, false);
+ if Width <> 0 then w := Width;
+ if Height <> 0 then h := Height;
+ SetBounds(Left, Top, w, h);
+ end;
+end;
+
+procedure TCustomCheckControlEx.DoAutoAdjustLayout(
+ const AMode: TLayoutAdjustmentPolicy;
+ const AXProportion, AYProportion: Double);
+begin
+ inherited;
+ if AMode in [lapAutoAdjustWithoutHorizontalScrolling, lapAutoAdjustForDPI] then
+ begin
+ FDistance := Round(cIndent * AXProportion);
+ FFocusBorder := FDistance div 2;
+ end;
+end;
+
+procedure TCustomCheckControlEx.DoClick;
+begin
+ if FReadOnly then
+ exit;
+
+ if AllowGrayed then begin
+ case FState of
+ cbUnchecked: SetState(cbGrayed);
+ cbGrayed: SetState(cbChecked);
+ cbChecked: SetState(cbUnchecked);
+ end;
+ end else
+ Checked := not Checked;
+end;
+
+procedure TCustomCheckControlEx.DoEnter;
+begin
+ inherited DoEnter;
+ Invalidate;
+end;
+
+procedure TCustomCheckControlEx.DoExit;
+begin
+ inherited DoExit;
+ Invalidate;
+end;
+
+procedure TCustomCheckControlEx.DrawBackground;
+var
+ R: TRect;
+begin
+ R := Rect(0, 0, Width, Height);
+ Canvas.Brush.Style := bsSolid;
+ Canvas.Brush.Color := Color;
+ Canvas.FillRect(R);
+end;
+
+procedure TCustomCheckControlEx.DrawButton(AHovered, APressed, AEnabled: Boolean; AState: TCheckboxState);
+var
+ btnRect: TRect;
+ btnPoint: TPoint = (X:0; Y:0);
+ details: TThemedElementDetails;
+ imgIndex: Integer;
+ imgRes: TScaledImageListResolution;
+ btnSize: TSize;
+begin
+ // Checkbox/Radiobutton size and position
+ btnSize := GetBtnSize;
+ case FAlignment of
+ taLeftJustify:
+ if not IsRightToLeft then btnPoint.X := ClientWidth - btnSize.CX;
+ taRightJustify:
+ if IsRightToLeft then btnPoint.X := ClientWidth - btnSize.CX;
+ end;
+ case FBtnLayout of
+ tlTop: btnPoint.Y := FFocusBorder;
+ tlCenter: btnPoint.Y := (ClientHeight - btnSize.CY) div 2;
+ tlBottom: btnPoint.Y := ClientHeight - btnSize.CY - FFocusBorder;
+ end;
+ btnRect := Rect(0, 0, btnSize.CX, btnSize.CY);
+ OffsetRect(btnRect, btnPoint.X, btnPoint.Y);
+
+ imgIndex := -1;
+ if (FImages <> nil) and Assigned(FOnGetImageIndex) then
+ FOnGetImageIndex(Self, AHovered, APressed, AEnabled, AState, imgIndex);
+
+ if imgIndex > -1 then
+ begin
+ ImgRes := FImages.ResolutionForPPI[FImagesWidth, Font.PixelsPerInch, GetCanvasScaleFactor];
+ ImgRes.Draw(Canvas, btnRect.Left, btnRect.Top, imgIndex, AEnabled);
+ end else
+ begin
+ // Drawing style of button
+ details := GetThemedButtonDetails(AHovered, APressed, AEnabled, AState);
+ // Draw button
+ ThemeServices.DrawElement(Canvas.Handle, details, btnRect);
+ end;
+end;
+
+procedure TCustomCheckControlEx.DrawButtonText(AHovered, APressed, AEnabled: Boolean;
+ AState: TCheckboxState);
+var
+ R: TRect;
+// textStyle: TTextStyle;
+ delta: Integer;
+ details: TThemedElementDetails;
+ flags: Cardinal;
+ textSize: TSize;
+ captn: TCaption;
+ btnSize: TSize;
+begin
+ captn := inherited Caption; // internal string with line breaks
+
+ if captn = '' then
+ exit;
+
+ // Determine text drawing parameters
+ flags := GetDrawTextFlags;
+
+ btnSize := GetBtnSize;
+ delta := btnSize.CX + FDistance;
+ R := ClientRect;
+ dec(R.Right, delta);
+ Canvas.Font.Assign(Font);
+ if FThemedCaption then
+ begin
+ R.Bottom := MaxInt; // max height for word-wrap
+ details := GetThemedButtonDetails(AHovered, APressed, AEnabled, AState);
+ with ThemeServices.GetTextExtent(Canvas.Handle, details, captn, flags, @R) do begin
+ textSize.CX := Right;
+ textSize.CY := Bottom;
+ end;
+ end else
+ begin
+ if not AEnabled then Canvas.Font.Color := clGrayText;
+ DrawText(Canvas.Handle, PChar(captn), Length(captn), R, flags + DT_CALCRECT);
+ textSize.CX := R.Right - R.Left;
+ textSize.CY := R.Bottom - R.Top;
+ end;
+
+ R := ClientRect;
+
+ case FTextLayout of
+ tlTop:
+ R.Top := 0;
+ tlCenter:
+ R.Top := (R.Top + R.Bottom - textSize.CY) div 2;
+ tlBottom:
+ R.Top := R.Bottom - textSize.CY;
+ end;
+ R.Bottom := R.Top + textSize.CY;
+
+ if (FAlignment = taRightJustify) and IsRightToLeft then
+ begin
+ dec(R.Right, delta);
+ R.Left := R.Right - textSize.CX;
+ end else
+ begin
+ inc(R.Left, delta);
+ R.Right := R.Left + textSize.CX;
+ end;
+
+ // Draw text
+ if FThemedCaption then
+ begin
+ ThemeServices.DrawText(Canvas, details, captn, R, flags, 0);
+ end else
+ begin
+ Canvas.Brush.Style := bsClear;
+ DrawText(Canvas.Handle, PChar(captn), Length(captn), R, flags);
+ end;
+
+ // Draw focus rect
+ if Focused and FDrawFocusRect then begin
+ InflateRect(R, FFocusBorder, 0);
+ if R.Left + R.Width > ClientWidth then R.Width := ClientWidth - R.Left;
+ if R.Left < 0 then R.Left := 0;
+ //LCLIntf.SetBkColor(Canvas.Handle, ColorToRGB(clBtnFace));
+ Canvas.Font.Color := clBlack;
+ LCLIntf.DrawFocusRect(Canvas.Handle, R);
+ end;
+end;
+
+function TCustomCheckControlEx.GetBtnSize: TSize;
+var
+ ImgRes: TScaledImageListResolution;
+begin
+ if (FImages <> nil) then begin
+ ImgRes := FImages.ResolutionForPPI[FImagesWidth, Font.PixelsPerInch, GetCanvasScaleFactor];
+ Result.CX := ImgRes.Width;
+ Result.CY := ImgRes.Height;
+ end else
+ begin
+ with ThemeServices do
+ if FKind = cckCheckbox then
+ Result := GetDetailSize(GetElementDetails(tbCheckBoxCheckedNormal))
+ else
+ if FKind = cckRadioButton then
+ Result := GetDetailSize(GetElementDetails(tbRadioButtonCheckedNormal));
+ //Result.CX := Scale96ToFont(Result.CX);
+ //Result.CY := Scale96ToFont(Result.CY);
+ end;
+end;
+
+// Replaces linebreaks in the inherited Caption by '\n' (and '\' by '\\') so
+// that line breaks can be entered at designtime.
+function TCustomCheckControlEx.GetCaption: TCaption;
+const
+ TO_C = true;
+begin
+ Result := ProcessLineBreaks(inherited Caption, TO_C);
+end;
+
+function TCustomCheckControlEx.GetChecked: Boolean;
+begin
+ Result := (FState = cbChecked);
+end;
+
+// Determine text drawing parameters for the DrawText command
+function TCustomCheckControlEx.GetDrawTextFlags: Cardinal;
+begin
+ Result := 0;
+ case FTextLayout of
+ tlTop: inc(Result, DT_TOP);
+ tlCenter: inc(Result, DT_VCENTER);
+ tlBottom: inc(Result, DT_BOTTOM);
+ end;
+
+ if (FAlignment = taRightJustify) and IsRightToLeft then
+ inc(Result, DT_RIGHT)
+ else
+ inc(Result, DT_LEFT);
+
+ if IsRightToLeft then inc(Result, DT_RTLREADING);
+ if FWordWrap then inc(Result, DT_WORDBREAK);
+end;
+
+function TCustomCheckControlEx.GetTextExtent(const ACaption: String): TSize;
+var
+ L: TStrings;
+ s: String;
+begin
+ Result := Size(0, 0);
+ L := TStringList.Create;
+ try
+ L.Text := ACaption;
+ for s in L do
+ begin
+ Result.CY := Result.CY + Canvas.TextHeight(s);
+ Result.CX := Max(Result.CX, Canvas.TextWidth(s));
+ end;
+ finally
+ L.Free;
+ end;
+end;
+ (*
+procedure TCustomCheckControlEx.InitBtnSize(Scaled: Boolean);
+var
+ ImgRes: TScaledImageListResolution;
+begin
+ if (FImages <> nil) then begin
+ if Scaled then begin
+ ImgRes := FImages.ResolutionForPPI[FImagesWidth, Font.PixelsPerInch, GetCanvasScaleFactor];
+ FBtnSize.CX := ImgRes.Width;
+ FBtnSize.CY := ImgRes.Height;
+ end else
+ begin
+ FBtnSize.CX := FImages.Width;
+ FBtnSize.CY := FImages.Height;
+ end;
+ end else
+ begin
+ with ThemeServices do
+ if FKind = cckCheckbox then
+ FBtnSize := GetDetailSize(GetElementDetails(tbCheckBoxCheckedNormal))
+ else if FKind = cckRadioButton then
+ FBtnSize := GetDetailSize(GetElementDetails(tbRadioButtonCheckedNormal));
+ if Scaled then
+ begin
+ FBtnSize.CX := Scale96ToFont(FBtnSize.CX);
+ FBtnSize.CY := Scale96ToFont(FBtnSize.CY);
+ end;
+ end;
+end;
+*)
+
+procedure TCustomCheckControlEx.KeyDown(var Key: Word; Shift: TShiftState);
+begin
+ inherited KeyDown(Key, Shift);
+ if (Key in [VK_RETURN, VK_SPACE]) and not (ssCtrl in Shift) and (not FReadOnly) then
+ begin
+ FPressed := True;
+ Invalidate;
+ end;
+end;
+
+procedure TCustomCheckControlEx.KeyUp(var Key: Word; Shift: TShiftState);
+begin
+ inherited KeyUp(Key, Shift);
+ if (Key in [VK_RETURN, VK_SPACE]) and not (ssCtrl in Shift) then
+ begin
+ FPressed := False;
+ DoClick;
+ end;
+end;
+
+procedure TCustomCheckControlEx.LockGroup;
+begin
+ inc(FGroupLock);
+end;
+
+procedure TCustomCheckControlEx.MouseDown(Button: TMouseButton;
+ Shift: TShiftState; X, Y: Integer);
+begin
+ inherited MouseDown(Button, Shift, X, Y);
+ if (Button = mbLeft) and FHover and not FReadOnly then
+ begin
+ FPressed := True;
+ Invalidate;
+ end;
+ SetFocus;
+end;
+
+procedure TCustomCheckControlEx.MouseEnter;
+begin
+ FHover := true;
+ Invalidate;
+ inherited;
+end;
+
+procedure TCustomCheckControlEx.MouseLeave;
+begin
+ FHover := false;
+ Invalidate;
+ inherited;
+end;
+
+procedure TCustomCheckControlEx.MouseUp(Button: TMouseButton;
+ Shift: TShiftState; X, Y: Integer);
+begin
+ inherited MouseUp(Button, Shift, X, Y);
+ if Button = mbLeft then begin
+ if PtInRect(ClientRect, Point(X, Y)) then DoClick;
+ FPressed := False;
+ end;
+end;
+
+procedure TCustomCheckControlEx.Paint;
+begin
+ {
+ if FTransparent then
+ DrawParentImage(Self, Self.Canvas)
+ else
+ DrawBackground;
+ }
+ DrawButton(FHover, FPressed, IsEnabled, FState);
+ DrawButtonText(FHover, FPressed, IsEnabled, FState);
+end;
+
+procedure TCustomCheckControlEx.SetAlignment(const AValue: TLeftRight);
+begin
+ if AValue = FAlignment then exit;
+ FAlignment := AValue;
+ Invalidate;
+end;
+
+procedure TCustomCheckControlEx.SetBtnLayout(const AValue: TTextLayout);
+begin
+ if AValue = FBtnLayout then exit;
+ FBtnLayout := AValue;
+ Invalidate;
+end;
+
+procedure TCustomCheckControlEx.SetCaption(const AValue: TCaption);
+const
+ FROM_C = false;
+begin
+ if AValue = GetCaption then exit;
+ inherited Caption := ProcessLineBreaks(AValue, FROM_C);
+end;
+
+procedure TCustomCheckControlEx.SetChecked(const AValue: Boolean);
+begin
+ if AValue then
+ State := cbChecked
+ else
+ State := cbUnChecked;
+end;
+
+procedure TCustomCheckControlEx.SetDrawFocusRect(const AValue: Boolean);
+begin
+ if AValue = FDrawFocusRect then exit;
+ FDrawFocusRect := AValue;
+ Invalidate;
+end;
+
+procedure TCustomCheckControlEx.SetImages(const AValue: TCustomImageList);
+begin
+ if AValue = FImages then exit;
+ FImages := AValue;
+// InitBtnSize(true);
+ InvalidatePreferredSize;
+ AdjustSize;
+end;
+
+procedure TCustomCheckControlEx.SetImagesWidth(const AValue: Integer);
+begin
+ if AValue = FImagesWidth then exit;
+ FImagesWidth := AValue;
+// InitBtnSize(true);
+ InvalidatePreferredSize;
+ AdjustSize;
+end;
+
+procedure TCustomCheckControlEx.SetTextLayout(const AValue: TTextLayout);
+begin
+ if AValue = FTextLayout then exit;
+ FTextLayout := AValue;
+ Invalidate;
+end;
+
+procedure TCustomCheckControlEx.SetThemedCaption(const AValue: Boolean);
+begin
+ if AValue = FThemedCaption then exit;
+ FThemedCaption := AValue;
+ Invalidate;
+end;
+
+procedure TCustomCheckControlEx.SetState(const AValue: TCheckboxState);
+begin
+ if (FState = AValue) then exit;
+ FState := AValue;
+ if [csLoading, csDestroying, csDesigning] * ComponentState = [] then begin
+ if Assigned(OnEditingDone) then OnEditingDone(self);
+ if Assigned(OnChange) then OnChange(self);
+ {
+ // Execute only when Action.Checked is changed
+ if not CheckFromAction then begin
+ if Assigned(OnClick) then
+ if not (Assigned(Action) and
+ CompareMethods(TMethod(Action.OnExecute), TMethod(OnClick)))
+ then OnClick(self);
+ if (Action is TCustomAction) and
+ (TCustomAction(Action).Checked <> (AValue = cbChecked))
+ then ActionLink.Execute(self);
+ end;
+ }
+ AfterSetState;
+ end;
+ Invalidate;
+end;
+{
+procedure TCustomCheckControlEx.SetTransparent(const AValue: Boolean);
+begin
+ if AValue = FTransparent then exit;
+ FTransparent := AValue;
+ Invalidate;
+end;
+}
+
+procedure TCustomCheckControlEx.SetWordWrap(const AValue: Boolean);
+begin
+ if AValue = FWordWrap then exit;
+ FWordWrap := AValue;
+ Invalidate;
+end;
+
+procedure TCustomCheckControlEx.TextChanged;
+begin
+ inherited TextChanged;
+ Invalidate;
+end;
+
+procedure TCustomCheckControlEx.UnlockGroup;
+begin
+ dec(FGroupLock);
+end;
+
+procedure TCustomCheckControlEx.WMSize(var Message: TLMSize);
+begin
+ inherited WMSize(Message);
+ Invalidate;
+end;
+
+
+{ TCustomRadioButtonEx }
+
+constructor TCustomRadioButtonEx.Create(AOwner: TComponent);
+begin
+ inherited;
+ FKind := cckRadioButton;
+// InitBtnSize(false);
+end;
+
+{ Is called by SetState and is supposed to uncheck all other radiobuttons in the
+ same group, i.e. having the same parent. Provides a locking mechanism because
+ uncheding another radiobutton would trigger AfterSetState again. }
+procedure TCustomRadioButtonEx.AfterSetState;
+var
+ i: Integer;
+ C: TControl;
+begin
+ if (FGroupLock > 0) or (Parent = nil) then
+ exit;
+ for i := 0 to Parent.ControlCount-1 do
+ begin
+ C := Parent.Controls[i];
+ if (C is TCustomRadioButtonEx) and (C <> self) then
+ with TCustomRadioButtonEx(C) do
+ begin
+ LockGroup;
+ try
+ State := cbUnChecked;
+ finally
+ UnlockGroup;
+ end;
+ end;
+ end;
+// Parent.Invalidate;
+end;
+
+function TCustomRadioButtonEx.GetThemedButtonDetails(
+ AHovered, APressed, AEnabled: Boolean; AState: TCheckboxState): TThemedElementDetails;
+var
+ offset: Integer = 0;
+ tb: TThemedButton;
+begin
+ offset := ord(FIRST_RADIOBUTTON_DETAIL);
+ if APressed then
+ inc(offset, PRESSED_OFFSET)
+ else if AHovered then
+ inc(offset, HOT_OFFSET);
+ if not AEnabled then inc(offset, DISABLED_OFFSET);
+ if AState = cbChecked then inc(offset, CHECKED_OFFSET);
+ tb := TThemedButton(offset);
+ Result := ThemeServices.GetElementDetails(tb);
+end;
+(*
+ offset := 0
+const // hovered pressed state
+ caEnabledDetails: array [False..True, False..True, cbUnChecked..cbChecked] of TThemedElementDetails =
+ (
+ (
+ (tbRadioButtonUncheckedNormal, tbRadioButtonCheckedNormal),
+ (tbRadioButtonUncheckedPressed, tbRadioButtonCheckedPressed)
+ ),
+ (
+ (tbRadioButtonUncheckedHot, tbRadioButtonCheckedHot),
+ (tbRadioButtonUncheckedPressed, tbRadioButtonCheckedPressed)
+ )
+ );
+
+ caDisabledDetails: array [cbUnchecked..cbChecked] of TThemedButton =
+ (tbRadioButtonUncheckedDisabled, tbRadioButtonCheckedDisabled);
+begin
+ if Enabled then
+ Result := caEnabledDetails[AHovered, APressed, AState]
+ else
+ Result := caDisabledDetails[AState];
+end;
+ *)
+
+
+{==============================================================================}
+{ TCustomCheckboxEx }
+{==============================================================================}
+
+constructor TCustomCheckboxEx.Create(AOwner: TComponent);
+begin
+ inherited;
+ FKind := cckCheckbox;
+// InitBtnSize(false);
+end;
+
+function TCustomCheckBoxEx.GetThemedButtonDetails(
+ AHovered, APressed, AEnabled: Boolean; AState: TCheckboxState): TThemedElementDetails;
+var
+ offset: Integer = 0;
+ tb: TThemedButton;
+begin
+ offset := ord(FIRST_CHECKBOX_DETAIL);
+ if APressed then
+ inc(offset, PRESSED_OFFSET)
+ else if AHovered then
+ inc(offset, HOT_OFFSET);
+ if not AEnabled then inc(offset, DISABLED_OFFSET);
+ case AState of
+ cbChecked: inc(offset, CHECKED_OFFSET);
+ cbGrayed: inc(offset, MIXED_OFFSET);
+ end;
+ tb := TThemedButton(offset);
+ Result := ThemeServices.GetElementDetails(tb);
+end;
+ (*
+
+const // hovered pressed state
+ caEnabledDetails: array [False..True, False..True, cbUnchecked..cbGrayed] of TThemedButton =
+ (
+ (
+ (tbCheckBoxUncheckedNormal, tbCheckBoxCheckedNormal, tbCheckBoxMixedNormal),
+ (tbCheckBoxUncheckedPressed, tbCheckBoxCheckedPressed, tbCheckBoxMixedPressed)
+ ),
+ (
+ (tbCheckBoxUncheckedHot, tbCheckBoxCheckedHot, tbCheckBoxMixedHot),
+ (tbCheckBoxUncheckedPressed, tbCheckBoxCheckedPressed, tbCheckBoxMixedPressed)
+ )
+ );
+
+ caDisabledDetails: array [cbUnchecked..cbGrayed] of TThemedButton =
+ (tbCheckBoxUncheckedDisabled, tbCheckBoxCheckedDisabled, tbCheckBoxMixedDisabled);
+var
+ tb: TThemedButton;
+begin
+ if Enabled then
+ tb := caEnabledDetails[AHovered, APressed, AState]
+ else
+ tb := caDisabledDetails[AState];
+ Result := ThemeServices.GetElementDetails(tb);
+end; *)
+
+
+{==============================================================================}
+{ TCustomCheckControlGroupEx }
+{==============================================================================}
+constructor TCustomCheckControlGroupEx.Create(AOwner: TComponent);
+begin
+ inherited;
+ FAutoFill := true;
+ FButtonList := TFPList.Create;
+ FColumns := 1;
+ FColumnLayout := clHorizontalThenVertical;
+ ChildSizing.Layout := cclLeftToRightThenTopToBottom;
+ ChildSizing.ControlsPerLine := FColumns;
+ ChildSizing.ShrinkHorizontal := crsScaleChilds;
+ ChildSizing.ShrinkVertical := crsScaleChilds;
+ ChildSizing.EnlargeHorizontal := crsHomogenousChildResize;
+ ChildSizing.EnlargeVertical := crsHomogenousChildResize;
+ ChildSizing.LeftRightSpacing := 6;
+ ChildSizing.TopBottomSpacing := 0;
+end;
+
+destructor TCustomCheckControlGroupEx.Destroy;
+var
+ i: Integer;
+begin
+ for i:=0 to FButtonList.Count-1 do
+ TCustomCheckControlEx(FButtonList[i]).Free;
+ FButtonList.Free;
+ FItems.Free;
+ inherited;
+end;
+
+function TCustomCheckControlGroupEx.CanModify: Boolean;
+begin
+ Result := not FReadOnly;
+end;
+
+procedure TCustomCheckControlgroupEx.FlipChildren(AllLevels: Boolean);
+begin
+ // no flipping
+end;
+
+procedure TCustomCheckControlGroupEx.ItemEnter(Sender: TObject);
+begin
+ DoEnter;
+end;
+
+procedure TCustomCheckControlGroupEx.ItemExit(Sender: TObject);
+begin
+ DoExit;
+end;
+
+procedure TCustomCheckControlGroupEx.ItemKeyDown(Sender: TObject;
+ var Key: Word; Shift: TShiftState);
+begin
+ if Key <> 0 then
+ KeyDown(Key, Shift);
+end;
+
+procedure TCustomCheckControlGroupEx.ItemKeyUp(Sender: TObject; var Key: Word;
+ Shift: TShiftState);
+begin
+ if Key <> 0 then
+ KeyUp(Key, Shift);
+end;
+
+procedure TCustomCheckControlGroupEx.ItemKeyPress(Sender: TObject; var Key: Char);
+begin
+ if Key <> #0 then
+ KeyPress(Key);
+end;
+
+procedure TCustomCheckControlGroupEx.ItemUTF8KeyPress(Sender: TObject;
+ var UTF8Key: TUTF8Char);
+begin
+ UTF8KeyPress(UTF8Key);
+end;
+
+procedure TCustomCheckControlGroupEx.ItemResize(Sender: TObject);
+begin
+ //
+end;
+
+function TCustomCheckControlGroupEx.Rows: integer;
+begin
+ if FItems.Count > 0 then
+ Result := ((FItems.Count-1) div Columns) + 1
+ else
+ Result := 0;
+end;
+
+procedure TCustomCheckControlGroupEx.SetAutoFill(const AValue: Boolean);
+begin
+ if FAutoFill = AValue then exit;
+ FAutoFill := AValue;
+ DisableAlign;
+ try
+ if FAutoFill then begin
+ ChildSizing.EnlargeHorizontal := crsHomogenousChildResize;
+ ChildSizing.EnlargeVertical := crsHomogenousChildResize;
+ end else begin
+ ChildSizing.EnlargeHorizontal := crsAnchorAligning;
+ ChildSizing.EnlargeVertical := crsAnchorAligning;
+ end;
+ finally
+ EnableAlign;
+ end;
+end;
+
+procedure TCustomCheckControlGroupEx.SetColumnLayout(const AValue: TColumnLayout);
+begin
+ if FColumnLayout = AValue then exit;
+ FColumnLayout := AValue;
+ if FColumnLayout = clHorizontalThenVertical then
+ ChildSizing.Layout := cclLeftToRightThenTopToBottom
+ else
+ ChildSizing.Layout := cclTopToBottomThenLeftToRight;
+ UpdateControlsPerLine;
+end;
+
+procedure TCustomCheckControlGroupEx.SetColumns(const AValue: integer);
+begin
+ if AValue <> FColumns then begin
+ if (AValue < 1) then
+ raise Exception.Create('TCustomRadioGroup: Columns must be >= 1');
+ FColumns := AValue;
+ UpdateControlsPerLine;
+ end;
+end;
+
+procedure TCustomCheckControlGroupEx.SetOnGetImageIndex(const AValue: TGetImageIndexEvent);
+var
+ i: Integer;
+begin
+ FOnGetImageIndex := AValue;
+ for i := 0 to FButtonList.Count - 1 do
+ TCustomCheckControlEx(FButtonList[i]).OnGetImageIndex := AValue;
+end;
+
+procedure TCustomCheckControlGroupEx.SetImages(const AValue: TCustomImagelist);
+var
+ i: Integer;
+begin
+ if AValue = FImages then exit;
+ FImages := AValue;
+ for i:=0 to FButtonList.Count-1 do
+ TCustomCheckControlEx(FButtonList[i]).Images := FImages;
+end;
+
+procedure TCustomCheckControlGroupEx.SetImagesWidth(const AValue: Integer);
+var
+ i: Integer;
+begin
+ if AValue = FImagesWidth then exit;
+ FImagesWidth := AValue;
+ for i := 0 to FButtonList.Count - 1 do
+ TCustomCheckControlEx(FButtonList[i]).ImagesWidth := FImagesWidth;
+end;
+
+procedure TCustomCheckControlGroupEx.SetItems(const AValue: TStrings);
+begin
+ if (AValue <> FItems) then
+ begin
+ FItems.Assign(AValue);
+ UpdateItems;
+ UpdateControlsPerLine;
+ end;
+end;
+
+procedure TCustomCheckControlGroupEx.SetReadOnly(const AValue: Boolean);
+var
+ i: Integer;
+begin
+ if AValue = FReadOnly then exit;
+ FReadOnly := AValue;
+ for i := 0 to FButtonList.Count -1 do
+ TCustomCheckControlEx(FButtonList[i]).ReadOnly := FReadOnly;
+end;
+
+procedure TCustomCheckControlGroupEx.UpdateAll;
+begin
+ UpdateItems;
+ UpdateControlsPerLine;
+ OwnerFormDesignerModified(Self);
+end;
+
+procedure TCustomCheckControlGroupEx.UpdateControlsPerLine;
+var
+ newControlsPerLine: LongInt;
+begin
+ if ChildSizing.Layout = cclLeftToRightThenTopToBottom then
+ newControlsPerLine := Max(1, FColumns)
+ else
+ newControlsPerLine := Max(1, Rows);
+ ChildSizing.ControlsPerLine := NewControlsPerLine;
+end;
+
+procedure TCustomCheckControlGroupEx.UpdateInternalObjectList;
+begin
+ UpdateItems;
+end;
+
+procedure TCustomCheckControlGroupEx.UpdateTabStops;
+var
+ i: Integer;
+ btn: TCustomCheckControlEx;
+begin
+ for i := 0 to FButtonList.Count - 1 do
+ begin
+ btn := TCustomCheckControlEx(FButtonList[i]);
+ btn.TabStop := btn.Checked;
+ end;
+end;
+
+{==============================================================================}
+{ TRadioGroupExStringList }
+{==============================================================================}
+
+type
+ TRadioGroupExStringList = class(TStringList)
+ private
+ FRadioGroup: TCustomRadioGroupEx;
+ protected
+ procedure Changed; override;
+ public
+ constructor Create(ARadioGroup: TCustomRadioGroupEx);
+ procedure Assign(Source: TPersistent); override;
+ end;
+
+constructor TRadioGroupExStringList.Create(ARadioGroup: TCustomRadioGroupEx);
+begin
+ inherited Create;
+ FRadioGroup := ARadioGroup;
+end;
+
+procedure TRadioGroupExStringList.Assign(Source: TPersistent);
+var
+ savedIndex: Integer;
+begin
+ savedIndex := FRadioGroup.ItemIndex;
+ inherited Assign(Source);
+ if savedIndex < Count then FRadioGroup.ItemIndex := savedIndex;
+end;
+
+procedure TRadioGroupExStringList.Changed;
+begin
+ inherited Changed;
+ if (UpdateCount = 0) then
+ FRadioGroup.UpdateAll
+ else
+ FRadioGroup.UpdateInternalObjectList;
+ FRadioGroup.FLastClickedItemIndex := FRadioGroup.FItemIndex;
+end;
+
+
+{==============================================================================}
+{ TCustomRadioGroupEx }
+{==============================================================================}
+
+constructor TCustomRadioGroupEx.Create(AOwner: TComponent);
+begin
+ inherited;
+ FItems := TRadioGroupExStringList.Create(Self);
+ FItemIndex := -1;
+ FLastClickedItemIndex := -1;
+end;
+
+procedure TCustomRadioGroupEx.Changed(Sender: TObject);
+begin
+ CheckItemIndexChanged;
+end;
+
+procedure TCustomRadioGroupEx.CheckItemIndexChanged;
+begin
+ if FCreatingWnd or FUpdatingItems then
+ exit;
+ if [csLoading,csDestroying]*ComponentState<>[] then exit;
+ UpdateRadioButtonStates;
+ if [csDesigning]*ComponentState<>[] then exit;
+ if FLastClickedItemIndex=FItemIndex then exit;
+ FLastClickedItemIndex:=FItemIndex;
+ EditingDone;
+ // for Delphi compatibility: OnClick should be invoked, whenever ItemIndex
+ // has changed
+ if Assigned (FOnClick) then FOnClick(Self);
+ // And a better named LCL equivalent
+ if Assigned (FOnSelectionChanged) then FOnSelectionChanged(Self);
+end;
+
+procedure TCustomRadioGroupEx.Clicked(Sender: TObject);
+begin
+ if FIgnoreClicks then exit;
+ CheckItemIndexChanged;
+end;
+
+function TCustomRadioGroupEx.GetButtonCount: Integer;
+var
+ i: Integer;
+begin
+ Result := 0;
+ for i := 0 to ControlCount-1 do
+ if (Controls[i] is TCustomRadioButtonEx) and (Controls[i] <> FHiddenButton) then
+ inc(Result);
+end;
+
+function TCustomRadioGroupEx.GetButtons(AIndex: Integer): TRadioButtonEx;
+begin
+ Result := Controls[AIndex] as TRadioButtonEx;
+end;
+
+procedure TCustomRadioGroupEx.InitializeWnd;
+
+ procedure RealizeItemIndex;
+ var
+ i: Integer;
+ begin
+ if (FItemIndex <> -1) and (FItemIndexnil then
+ FHiddenButton.Checked := true;
+ for i:=0 to FItems.Count-1 do begin
+ TRadioButtonEx(FButtonList[i]).Checked := (FItemIndex = i);
+ end;
+ end;
+
+begin
+ if FCreatingWnd then RaiseGDBException('TCustomRadioGroup.InitializeWnd');
+ FCreatingWnd := true;
+ UpdateItems;
+ inherited InitializeWnd;
+ RealizeItemIndex;
+ //debugln(['TCustomRadioGroup.InitializeWnd END']);
+ FCreatingWnd := false;
+end;
+
+procedure TCustomRadioGroupEx.ItemKeyDown(Sender: TObject; var Key: Word;
+ Shift: TShiftState);
+
+ procedure MoveSelection(HorzDiff, VertDiff: integer);
+ var
+ Count: integer;
+ StepSize: integer;
+ BlockSize : integer;
+ NewIndex : integer;
+ WrapOffset: integer;
+ begin
+ if FReadOnly then
+ exit;
+
+ Count := FButtonList.Count;
+ if FColumnLayout = clHorizontalThenVertical then begin
+ //add a row for ease wrapping
+ BlockSize := Columns * (Rows+1);
+ StepSize := HorzDiff + VertDiff * Columns;
+ WrapOffSet := VertDiff;
+ end
+ else begin
+ //add a column for ease wrapping
+ BlockSize := (Columns+1) * Rows;
+ StepSize := HorzDiff * Rows + VertDiff;
+ WrapOffSet := HorzDiff;
+ end;
+ NewIndex := ItemIndex;
+ repeat
+ Inc(NewIndex, StepSize);
+ if (NewIndex >= Count) or (NewIndex < 0) then begin
+ NewIndex := (NewIndex + WrapOffSet + BlockSize) mod BlockSize;
+ // Keep moving in the same direction until in valid range
+ while NewIndex >= Count do
+ NewIndex := (NewIndex + StepSize) mod BlockSize;
+ end;
+ until (NewIndex = ItemIndex) or TCustomCheckControlEx(FButtonList[NewIndex]).Enabled;
+ ItemIndex := NewIndex;
+ TCustomCheckControlEx(FButtonList[ItemIndex]).SetFocus;
+ Key := 0;
+ end;
+
+begin
+ if Shift=[] then begin
+ case Key of
+ VK_LEFT: MoveSelection(-1,0);
+ VK_RIGHT: MoveSelection(1,0);
+ VK_UP: MoveSelection(0,-1);
+ VK_DOWN: MoveSelection(0,1);
+ end;
+ end;
+ if Key <> 0 then
+ KeyDown(Key, Shift);
+end;
+
+procedure TCustomRadioGroupEx.ReadState(AReader: TReader);
+begin
+ FReading := True;
+ inherited ReadState(AReader);
+ FReading := False;
+ if (FItemIndex < -1) or (FItemIndex >= FItems.Count) then
+ FItemIndex := -1;
+ FLastClickedItemIndex := FItemIndex;
+end;
+
+procedure TCustomRadioGroupEx.SetItemIndex(const AValue: integer);
+var
+ oldItemIndex: LongInt;
+ oldIgnoreClicks: Boolean;
+begin
+ if (AValue = FItemIndex) or FReadOnly then exit;
+
+ // needed later if handle isn't allocated
+ oldItemIndex := FItemIndex;
+
+ if FReading then
+ FItemIndex := AValue
+ else begin
+ if (AValue < -1) or (AValue >= FItems.Count) then
+ raise Exception.CreateFmt(rsIndexOutOfBounds, [ClassName, AValue, FItems.Count-1]);
+
+ if HandleAllocated then
+ begin
+ // the radiobuttons are grouped by the widget interface
+ // and some does not allow to uncheck all buttons in a group
+ // Therefore there is a hidden button
+ FItemIndex := AValue;
+ oldIgnoreClicks := FIgnoreClicks;
+ FIgnoreClicks := true;
+ try
+ if (FItemIndex <> -1) then
+ TCustomCheckControlEx(FButtonList[FItemIndex]).Checked := true
+ else
+ FHiddenButton.Checked := true;
+ // uncheck old radiobutton
+ if (OldItemIndex <> -1) then begin
+ if (OldItemIndex >= 0) and (OldItemIndex < FButtonList.Count) then
+ TCustomCheckControlEx(FButtonList[OldItemIndex]).Checked := false
+ end else
+ FHiddenButton.Checked := false;
+ finally
+ FIgnoreClicks := OldIgnoreClicks;
+ end;
+ // this has automatically unset the old button. But they do not recognize
+ // it. Update the states.
+ CheckItemIndexChanged;
+ UpdateTabStops;
+ OwnerFormDesignerModified(Self);
+ end else
+ begin
+ FItemIndex := AValue;
+
+ // maybe handle was recreated. issue #26714
+ FLastClickedItemIndex := -1;
+
+ // trigger event to be delphi compat, even if handle isn't allocated.
+ // issue #15989
+ if (AValue <> oldItemIndex) and not FCreatingWnd then
+ begin
+ if Assigned(FOnClick) then FOnClick(Self);
+ if Assigned(FOnSelectionChanged) then FOnSelectionChanged(Self);
+ FLastClickedItemIndex := FItemIndex;
+ end;
+ end;
+ end;
+end;
+
+procedure TCustomRadioGroupEx.UpdateItems;
+var
+ i: integer;
+ button: TCustomCheckControlEx;
+begin
+ if FUpdatingItems then exit;
+ FUpdatingItems := true;
+ try
+ // destroy radiobuttons, if there are too many
+ while FButtonList.Count > FItems.Count do
+ begin
+ TObject(FButtonList[FButtonList.Count-1]).Free;
+ FButtonList.Delete(FButtonList.Count-1);
+ end;
+
+ // create as many TRadioButtons as needed
+ while (FButtonList.Count < FItems.Count) do
+ begin
+ button := TRadioButtonEx.Create(Self);
+ with TCustomCheckControlEx(button) do
+ begin
+ Name := 'RadioButtonEx' + IntToStr(FButtonList.Count);
+ OnClick := @Self.Clicked;
+ OnChange := @Self.Changed;
+ OnEnter := @Self.ItemEnter;
+ OnExit := @Self.ItemExit;
+ OnKeyDown := @Self.ItemKeyDown;
+ OnKeyUp := @Self.ItemKeyUp;
+ OnKeyPress := @Self.ItemKeyPress;
+ OnUTF8KeyPress := @Self.ItemUTF8KeyPress;
+ OnResize := @Self.ItemResize;
+ ParentFont := True;
+ ReadOnly := Self.ReadOnly;
+ BorderSpacing.CellAlignHorizontal := ccaLeftTop;
+ BorderSpacing.CellAlignVertical := ccaCenter;
+ ControlStyle := ControlStyle + [csNoDesignSelectable];
+ end;
+ FButtonList.Add(button);
+ end;
+ if FHiddenButton = nil then begin
+ FHiddenButton := TRadioButtonEx.Create(nil);
+ with FHiddenButton do
+ begin
+ Name := 'HiddenRadioButton';
+ Visible := False;
+ ControlStyle := ControlStyle + [csNoDesignSelectable, csNoDesignVisible];
+ end;
+ end;
+
+ if (FItemIndex >= FItems.Count) and not (csLoading in ComponentState) then
+ FItemIndex := FItems.Count-1;
+
+ if FItems.Count > 0 then
+ begin
+ // to reduce overhead do it in several steps
+
+ // assign Caption and then Parent
+ for i:=0 to FItems.Count-1 do
+ begin
+ button := TCustomCheckControlEx(FButtonList[i]);
+ button.Caption := FItems[i];
+ button.Parent := Self;
+ end;
+ FHiddenButton.Parent := Self;
+
+ // the checked and unchecked states can be applied only after all other
+ for i := 0 to FItems.Count-1 do
+ begin
+ button := TCustomCheckControlEx(FButtonList[i]);
+ button.Checked := (i = FItemIndex);
+ button.Visible := true;
+ end;
+
+ //FHiddenButton must remain the last item in Controls[], so that Controls[] is in sync with Items[]
+ Self.RemoveControl(FHiddenButton);
+ Self.InsertControl(FHiddenButton);
+ if HandleAllocated then
+ FHiddenButton.HandleNeeded;
+ FHiddenButton.Checked := (FItemIndex = -1);
+ UpdateTabStops;
+ end;
+ finally
+ FUpdatingItems := false;
+ end;
+end;
+
+procedure TCustomRadioGroupEx.UpdateRadioButtonStates;
+var
+ i: Integer;
+begin
+ if FReadOnly then
+ exit;
+
+ FItemIndex := -1;
+ FHiddenButton.Checked;
+ for i:=0 to FButtonList.Count-1 do
+ if TCustomRadioButtonEx(FButtonList[i]).Checked then FItemIndex := i;
+ UpdateTabStops;
+end;
+
+
+{==============================================================================}
+{ TCheckGroupExStringList }
+{==============================================================================}
+
+type
+ TCheckGroupExStringList = class(TStringList)
+ private
+ FCheckGroup: TCustomCheckGroupEx;
+ procedure RestoreCheckStates(const AStates: TByteDynArray);
+ procedure SaveCheckStates(out AStates: TByteDynArray);
+ protected
+ procedure Changed; override;
+ public
+ constructor Create(ACheckGroup: TCustomCheckGroupEx);
+ procedure Delete(AIndex: Integer); override;
+ end;
+
+
+constructor TCheckGroupExStringList.Create(ACheckGroup: TCustomCheckGroupEx);
+begin
+ inherited Create;
+ FCheckGroup := ACheckGroup;
+end;
+
+procedure TCheckGroupExStringList.Changed;
+begin
+ inherited Changed;
+ if UpdateCount = 0 then
+ FCheckGroup.UpdateAll
+ else
+ FCheckGroup.UpdateInternalObjectList;
+end;
+
+procedure TCheckGroupExStringList.Delete(AIndex: Integer);
+// Deleting destroys the checked state of the items -> we must save and restore it
+// Issue https://bugs.freepascal.org/view.php?id=34327.
+var
+ b: TByteDynArray;
+ i: Integer;
+begin
+ SaveCheckStates(b);
+
+ inherited Delete(AIndex);
+
+ for i:= AIndex to High(b)-1 do b[i] := b[i+1];
+ SetLength(b, Length(b)-1);
+ RestoreCheckStates(b);
+end;
+
+procedure TCheckGroupExStringList.RestoreCheckStates(const AStates: TByteDynArray);
+var
+ i: Integer;
+begin
+ Assert(Length(AStates) = FCheckGroup.Items.Count);
+ for i:=0 to FCheckgroup.Items.Count-1 do begin
+ FCheckGroup.Checked[i] := AStates[i] and 1 <> 0;
+ FCheckGroup.CheckEnabled[i] := AStates[i] and 2 <> 0;
+ end;
+end;
+
+procedure TCheckGroupExStringList.SaveCheckStates(out AStates: TByteDynArray);
+var
+ i: Integer;
+begin
+ SetLength(AStates, FCheckgroup.Items.Count);
+ for i:=0 to FCheckgroup.Items.Count-1 do begin
+ AStates[i] := 0;
+ if FCheckGroup.Checked[i] then inc(AStates[i]);
+ if FCheckGroup.CheckEnabled[i] then inc(AStates[i], 2);
+ end;
+end;
+
+
+{==============================================================================}
+{ TCustomCheckGroupEx }
+{==============================================================================}
+
+constructor TCustomCheckGroupEx.Create(AOwner: TComponent);
+begin
+ inherited;
+ FItems := TCheckGroupExStringList.Create(Self);
+end;
+
+procedure TCustomCheckGroupEx.Clicked(Sender: TObject);
+var
+ index: Integer;
+begin
+ index := FButtonList.IndexOf(Sender);
+ if index < 0 then exit;
+ DoClick(index);
+end;
+
+procedure TCustomCheckGroupEx.DefineProperties(Filer: TFiler);
+begin
+ inherited DefineProperties(Filer);
+ Filer.DefineBinaryProperty('Data', @ReadData, @WriteData, FItems.Count > 0);
+end;
+
+procedure TCustomCheckGroupEx.DoClick(AIndex: integer);
+begin
+ if [csLoading,csDestroying, csDesigning] * ComponentState <> [] then exit;
+ EditingDone;
+ if Assigned(FOnItemClick) then FOnItemClick(Self, AIndex);
+end;
+
+function TCustomCheckGroupEx.GetButtonCount: Integer;
+var
+ i: Integer;
+begin
+ Result := 0;
+ for i := 0 to ControlCount-1 do
+ if (Controls[i] is TCustomCheckBoxEx) then
+ inc(Result);
+end;
+
+function TCustomCheckGroupEx.GetButtons(AIndex: Integer): TCheckBoxEx;
+begin
+ Result := Controls[AIndex] as TCheckBoxEx;
+end;
+
+function TCustomCheckGroupEx.GetChecked(AIndex: Integer): Boolean;
+begin
+ if (AIndex < -1) or (AIndex >= FItems.Count) then
+ RaiseIndexOutOfBounds(AIndex);
+ Result := TCustomCheckControlEx(FButtonList[AIndex]).Checked;
+end;
+
+function TCustomCheckGroupEx.GetCheckEnabled(AIndex: integer): boolean;
+begin
+ if (AIndex < -1) or (AIndex >= FItems.Count) then
+ RaiseIndexOutOfBounds(AIndex);
+ Result := TCustomCheckControlEx(FButtonList[AIndex]).Enabled;
+end;
+
+procedure TCustomCheckGroupEx.Loaded;
+begin
+ inherited Loaded;
+ UpdateItems;
+end;
+
+procedure TCustomCheckGroupEx.RaiseIndexOutOfBounds(AIndex: integer);
+begin
+ raise Exception.CreateFmt(rsIndexOutOfBounds, [ClassName, AIndex, FItems.Count - 1]);
+end;
+
+procedure TCustomCheckGroupEx.ReadData(Stream: TStream);
+var
+ ChecksCount: integer;
+ Checks: string;
+ i: Integer;
+ v: Integer;
+begin
+ ChecksCount := ReadLRSInteger(Stream);
+ if ChecksCount > 0 then begin
+ SetLength(Checks, ChecksCount);
+ Stream.ReadBuffer(Checks[1], ChecksCount);
+ for i:=0 to ChecksCount-1 do begin
+ v := ord(Checks[i+1]);
+ Checked[i] := ((v and 1) > 0);
+ CheckEnabled[i] := ((v and 2) > 0);
+ end;
+ end;
+end;
+
+procedure TCustomCheckGroupEx.SetChecked(AIndex: integer; const AValue: boolean);
+begin
+ if (AIndex < -1) or (AIndex >= FItems.Count) then
+ RaiseIndexOutOfBounds(AIndex);
+ // disable OnClick
+ TCheckBox(FButtonList[AIndex]).OnClick := nil;
+ // set value
+ TCheckBox(FButtonList[AIndex]).Checked := AValue;
+ // enable OnClick
+ TCheckBox(FButtonList[AIndex]).OnClick := @Clicked;
+end;
+
+procedure TCustomCheckGroupEx.SetCheckEnabled(AIndex: integer;
+ const AValue: boolean);
+begin
+ if (AIndex < -1) or (AIndex >= FItems.Count) then
+ RaiseIndexOutOfBounds(AIndex);
+ TCustomCheckControlEx(FButtonList[AIndex]).Enabled := AValue;
+end;
+
+procedure TCustomCheckGroupEx.UpdateItems;
+var
+ i: integer;
+ btn: TCustomCheckControlEx;
+begin
+ if FUpdatingItems then exit;
+ FUpdatingItems := true;
+ try
+ // destroy checkboxes, if there are too many
+ while FButtonList.Count > FItems.Count do begin
+ TObject(FButtonList[FButtonList.Count-1]).Free;
+ FButtonList.Delete(FButtonList.Count-1);
+ end;
+
+ // create as many TCheckBoxes as needed
+ while (FButtonList.Count < FItems.Count) do begin
+ btn := TCheckBoxEx.Create(Self);
+ with TCheckBoxEx(btn) do begin
+ Name := 'CheckBoxEx' + IntToStr(FButtonList.Count);
+ OnClick := @Self.Clicked;
+ OnKeyDown := @Self.ItemKeyDown;
+ OnKeyUp := @Self.ItemKeyUp;
+ OnKeyPress := @Self.ItemKeyPress;
+ OnUTF8KeyPress := @Self.ItemUTF8KeyPress;
+ AutoSize := False;
+ Parent := Self;
+ ParentFont := true;
+ ReadOnly := Self.ReadOnly;
+ BorderSpacing.CellAlignHorizontal := ccaLeftTop;
+ BorderSpacing.CellAlignVertical := ccaCenter;
+ ControlStyle := ControlStyle + [csNoDesignSelectable];
+ end;
+ FButtonList.Add(btn);
+ end;
+
+ for i:=0 to FItems.Count-1 do begin
+ btn := TCustomCheckControlEx(FButtonList[i]);
+ btn.Caption := FItems[i];
+ end;
+ finally
+ FUpdatingItems := false;
+ end;
+end;
+
+procedure TCustomCheckGroupEx.WriteData(Stream: TStream);
+var
+ ChecksCount: integer;
+ Checks: string;
+ i: Integer;
+ v: Integer;
+begin
+ ChecksCount := FItems.Count;
+ WriteLRSInteger(Stream, ChecksCount);
+ if ChecksCount > 0 then begin
+ SetLength(Checks, ChecksCount);
+ for i := 0 to ChecksCount-1 do begin
+ v := 0;
+ if Checked[i] then inc(v, 1);
+ if CheckEnabled[i] then inc(v, 2);
+ Checks[i+1] := chr(v);
+ end;
+ Stream.WriteBuffer(Checks[1], ChecksCount);
+ end;
+end;
+
+end.
+
diff --git a/components/exctrls/source/exctrlsreg.pas b/components/exctrls/source/exctrlsreg.pas
new file mode 100644
index 000000000..61d5033d6
--- /dev/null
+++ b/components/exctrls/source/exctrlsreg.pas
@@ -0,0 +1,31 @@
+unit ExCtrlsReg;
+
+{$mode objfpc}{$H+}
+
+interface
+
+uses
+ Classes, SysUtils;
+
+procedure Register;
+
+implementation
+
+uses
+ ExCheckCtrls, ExEditCtrls;
+
+{$R exctrlsreg.res}
+
+procedure Register;
+begin
+ RegisterComponents('ExCtrls', [
+ TCheckboxEx, TRadioButtonEx, TCheckGroupEx, TRadioGroupEx
+ ]);
+ RegisterComponents('LazControls', [
+ TCurrSpinEditEx
+ ]);
+end;
+
+
+end.
+
diff --git a/components/exctrls/source/exctrlsreg.res b/components/exctrls/source/exctrlsreg.res
new file mode 100644
index 000000000..a2679ce11
Binary files /dev/null and b/components/exctrls/source/exctrlsreg.res differ
diff --git a/components/exctrls/source/exeditctrls.pas b/components/exctrls/source/exeditctrls.pas
new file mode 100644
index 000000000..cc59d48e9
--- /dev/null
+++ b/components/exctrls/source/exeditctrls.pas
@@ -0,0 +1,404 @@
+unit ExEditCtrls;
+
+{$mode objfpc}{$H+}
+
+{.$define debug_editctrls}
+
+interface
+
+uses
+ Classes, SysUtils, Controls, SpinEx;
+
+type
+ { TCustomCurrEditEx }
+ TSpinEditCurrencyFormat = (
+ secfCurrVal, // 0: $1
+ secfValCurr, // 1: 1$
+ secfCurrSpaceVal, // 2: $ 1
+ secfValSpaceCurr // 3: 1 $
+ );
+ TSpinEditNegCurrencyFormat = (
+ sencfParCurrValPar, // 0: ($1)
+ sencfMinusCurrVal, // 1: -1$
+ sencfCurrMinusVal, // 2: $-1
+ sencfCurrValMinus, // 3: $1-
+ sencfParValCurrPar, // 4: (1$)
+ sencfMinusValCurr, // 5: -1$
+ sencfValMinusCurr, // 6: 1-$
+ sencfValCurrMinus, // 7: 1$-
+ sencfMinusValSpaceCurr, // 8: -1 $
+ sencfMinusCurrSpaceVal, // 9: -$ 1
+ sencfValSpaceCurrMinus, //10: 1 $-
+ sencfCurrSpaceValMinus, //11: $ 1-
+ sencfCurrSpaceMinusVal, //12: $ -1
+ sencfValMinusSpaceCurr, //13: 1- $
+ sencfParCurrSpaceValPar, //14: ($ 1)
+ sencfParValSpaceCurrPar //15: (1 $)
+ );
+
+ TSpinEditCurrencyDecimals = 0..4;
+
+ TCustomCurrSpinEditEx = class(specialize TSpinEditExBase)
+ private
+ FCurrencyString: String;
+ FDecimals: TSpinEditCurrencyDecimals;
+ FCurrencyFormat: TSpinEditCurrencyFormat;
+ FDecimalSeparator: Char;
+ FNegCurrencyFormat: TSpinEditNegCurrencyFormat;
+ FThousandSeparator: Char;
+ function IsIncrementStored: Boolean;
+ procedure SetCurrencyFormat(AValue: TSpinEditCurrencyFormat);
+ procedure SetCurrencyString(AValue: String);
+ procedure SetDecimals(AValue: TSpinEditCurrencyDecimals);
+ procedure SetDecimalSeparator(AValue: Char);
+ procedure SetNegCurrencyFormat(AValue: TSpinEditNegCurrencyFormat);
+ procedure SetThousandSeparator(AValue: Char);
+ protected
+ procedure EditKeyPress(var Key: char); override;
+ function SafeInc(AValue: Currency): Currency; override;
+ function SafeDec(AValue: Currency): Currency; override;
+ function TextIsNumber(const S: String; out ANumber: Currency): Boolean; override;
+ function TryExtractCurrency(AText: String; out AValue: Currency;
+ const AFormatSettings: TFormatSettings): Boolean;
+ function UsedFormatSettings: TFormatSettings;
+ public
+ constructor Create(AOwner: TComponent); override;
+ function ValueToStr(const AValue: Currency): String; override;
+ procedure ResetFormatSettings;
+ function StrToValue(const S: String): Currency; override;
+ public
+ property Increment stored IsIncrementStored;
+ property CurrencyFormat: TSpinEditCurrencyFormat
+ read FCurrencyFormat write SetCurrencyFormat;
+ property CurrencyString: String
+ read FCurrencyString write SetCurrencyString;
+ property Decimals: TSpinEditCurrencyDecimals
+ read FDecimals write SetDecimals;
+ property DecimalSeparator: Char
+ read FDecimalSeparator write SetDecimalSeparator;
+ property NegCurrencyFormat: TSpinEditNegCurrencyFormat
+ read FNegCurrencyFormat write SetNegCurrencyFormat;
+ property ThousandSeparator: Char
+ read FThousandSeparator write SetThousandSeparator;
+ end;
+
+ { TCurrSpinEdit }
+
+ TCurrSpinEditEx = class(TCustomCurrSpinEditEx)
+ public
+ property AutoSelected;
+ published
+ //From TCustomEdit
+ property AutoSelect;
+ property AutoSizeHeightIsEditHeight;
+ property AutoSize default True;
+ property Action;
+ property Align;
+ property Alignment default taRightJustify;
+ property Anchors;
+ property BiDiMode;
+ property BorderSpacing;
+ property BorderStyle default bsNone;
+ property CharCase;
+ property Color;
+ property Constraints;
+ property Cursor;
+ property DirectInput;
+ property EchoMode;
+ property Enabled;
+ property FocusOnBuddyClick;
+ property Font;
+ property Hint;
+ property Layout;
+ property MaxLength;
+ property NumbersOnly;
+ property ParentBiDiMode;
+ property ParentColor;
+ property ParentFont;
+ property ParentShowHint;
+ property PopupMenu;
+ property ReadOnly;
+ property ShowHint;
+ property TabOrder;
+ property TabStop;
+ property TextHint;
+ property Visible;
+
+ property OnChange;
+ property OnClick;
+ property OnDblClick;
+ property OnDragDrop;
+ property OnDragOver;
+ property OnContextPopup;
+ property OnEditingDone;
+ property OnEndDrag;
+ property OnEnter;
+ property OnExit;
+ property OnKeyDown;
+ property OnKeyPress;
+ property OnKeyUp;
+ property OnMouseDown;
+ property OnMouseEnter;
+ property OnMouseLeave;
+ property OnMouseMove;
+ property OnMouseUp;
+ property OnMouseWheel;
+ property OnMouseWheelDown;
+ property OnMouseWheelUp;
+ property OnStartDrag;
+ property OnUTF8KeyPress;
+
+ //From TCustomFloatSpinEditEx
+ property ArrowKeys;
+ property CurrencyFormat;
+ property CurrencyString;
+ property Decimals;
+ property DecimalSeparator;
+ property Increment;
+ property MaxValue;
+ property MinValue;
+ property MinRepeatValue;
+ property NegCurrencyFormat;
+ property NullValue;
+ property NullValueBehaviour;
+ property Spacing;
+ property ThousandSeparator;
+ property UpDownVisible;
+ property Value;
+ end;
+
+implementation
+
+uses
+ LCLProc;
+
+resourcestring
+ RsDecSepMustNotMatchThSep = 'Decimal and thousand separators most not be equal.';
+
+const
+ Digits = ['0'..'9'];
+ AllowedControlChars = [#8, #9, ^C, ^X, ^V, ^Z];
+
+{ TCustomCurrSpinEditEx }
+
+constructor TCustomCurrSpinEditEx.Create(AOwner: TComponent);
+begin
+ inherited;
+ FMaxValue := 0;
+ FMinValue := 0; // --> disable Max/Min check by default
+ ResetFormatSettings;
+end;
+
+procedure TCustomCurrSpinEditEx.EditKeyPress(var Key: char);
+begin
+ inherited EditKeyPress(Key);
+ {Disallow any key that is not a digit or -
+ Tab, BackSpace, Cut, Paste, Copy, Undo of course should be passed onto inherited KeyPress
+ }
+ if not (Key in (Digits + AllowedControlChars + ['-'])) then Key := #0;
+ if (Key = '-') and IsLimited and (MinValue >= 0) then Key := #0;
+end;
+
+procedure TCustomCurrSpinEditEx.ResetFormatSettings;
+begin
+ FDecimals := DefaultFormatSettings.CurrencyDecimals;
+ FCurrencyFormat := TSpinEditCurrencyFormat(DefaultFormatSettings.CurrencyFormat);
+ FCurrencyString := DefaultFormatSettings.CurrencyString;
+ FDecimalSeparator := DefaultFormatSettings.DecimalSeparator;
+ FNegCurrencyFormat := TSpinEditNegCurrencyFormat(DefaultFormatSettings.NegCurrFormat);
+ FThousandSeparator := DefaultFormatSettings.ThousandSeparator;
+end;
+
+function TCustomCurrSpinEditEx.IsIncrementStored: Boolean;
+begin
+ Result := FIncrement <> 1;
+end;
+
+function TCustomCurrSpinEditEx.SafeInc(AValue: Currency): Currency;
+begin
+ if (AValue > 0) and (AValue > MaxCurrency-FIncrement) then
+ Result := MaxCurrency
+ else
+ Result := AValue + FIncrement;
+end;
+
+function TCustomCurrSpinEditEx.SafeDec(AValue: Currency): Currency;
+begin
+ if (AValue < 0) and (MinCurrency + FIncrement > AValue) then
+ Result := MinCurrency
+ else
+ Result := AValue - FIncrement;
+end;
+
+procedure TCustomCurrSpinEditEx.SetCurrencyFormat(AValue: TSpinEditCurrencyFormat);
+begin
+ if AValue = FCurrencyFormat then exit;
+ FCurrencyFormat := AValue;
+ UpdateControl;
+end;
+
+procedure TCustomCurrSpinEditEx.SetCurrencyString(AValue: string);
+begin
+ if AValue = FCurrencyString then exit;
+ FCurrencyString := AValue;
+ UpdateControl;
+end;
+
+procedure TCustomCurrSpinEditEx.SetDecimals(AValue: TSpinEditCurrencyDecimals);
+begin
+ if AValue = FDecimals then exit;
+ FDecimals := AValue;
+ UpdateControl;
+end;
+
+procedure TCustomCurrSpinEditEx.SetDecimalSeparator(AValue: char);
+begin
+ if AValue = FDecimalSeparator then exit;
+ if (AValue = FThousandSeparator) and (ComponentState = []) then
+ raise Exception.Create(RsDecSepMustNotMatchThSep);
+ FDecimalSeparator := AValue;
+ UpdateControl;
+end;
+
+procedure TCustomCurrSpinEditEx.SetNegCurrencyFormat(
+ AValue: TSpinEditNegCurrencyFormat);
+begin
+ if AValue = FNegCurrencyFormat then exit;
+ FNegCurrencyFormat := AValue;
+ UpdateControl;
+end;
+
+procedure TCustomCurrSpinEditEx.SetThousandSeparator(AValue: char);
+begin
+ if AValue = FThousandSeparator then exit;
+ if AValue = FDecimalSeparator then
+ raise Exception.Create(RsDecSepMustNotMatchThSep);
+ FThousandSeparator := AValue;
+ UpdateControl;
+end;
+
+function TCustomCurrSpinEditEx.TextIsNumber(const S: String; out ANumber: Currency
+ ): Boolean;
+var
+ C: Currency;
+begin
+ {$ifdef debug_editctrls}
+ DbgOut(['TCustomSpinEditEx.TextIsNumber: S = "',S,'" Result = ']);
+ {$endif}
+
+ try
+ Result := TryExtractCurrency(S, C, UsedFormatSettings);
+// Result := TryStrToCurr(S, C);
+ ANumber := C;
+ except
+ Result := False;
+ end;
+ {$ifdef debug_editctrls}
+ debugln([Result]);
+ {$endif}
+end;
+
+function TCustomCurrSpinEditEx.TryExtractCurrency(AText: String;
+ out AValue: Currency; const AFormatSettings: TFormatSettings): Boolean;
+type
+ TParenthesis = (pNone, pOpen, pClose);
+var
+ isNeg: Boolean;
+ parenth: TParenthesis;
+ P: PChar;
+ PEnd: PChar;
+ s: String;
+ n: Integer;
+begin
+ Result := false;
+ if AText = '' then
+ exit;
+ isNeg := false;
+ parenth := pNone;
+ SetLength(s, Length(AText));
+ n := 1;
+ P := @AText[1];
+ PEnd := @AText[Length(AText)];
+ while P <= PEnd do begin
+ if (P^ in ['0'..'9']) or (P^ in [AFormatSettings.DecimalSeparator]) then
+ begin
+ s[n] := P^;
+ inc(n);
+ end else
+ if P^ = '-' then
+ isNeg := true
+ else
+ if P^ = '(' then begin
+ isNeg := true;
+ parenth := pOpen;
+ end else
+ if P^ = ')' then begin
+ if not IsNeg then
+ exit;
+ parenth := pClose;
+ end;
+ inc(P);
+ end;
+ if IsNeg and (parenth = pOpen) then
+ exit;
+ SetLength(s, n-1);
+ Result := TryStrToCurr(s, AValue, AFormatSettings);
+ if Result and isNeg then AValue := -AValue;
+end;
+
+function TCustomCurrSpinEditEx.UsedFormatSettings: TFormatSettings;
+begin
+ Result := DefaultFormatSettings;
+ Result.CurrencyFormat := ord(FCurrencyFormat);
+ Result.NegCurrFormat := ord(FNegCurrencyFormat);
+ Result.ThousandSeparator := FThousandSeparator;
+ Result.DecimalSeparator := FDecimalSeparator;
+ Result.CurrencyString := FCurrencyString;
+ Result.CurrencyDecimals := FDecimals;
+end;
+
+function TCustomCurrSpinEditEx.ValueToStr(const AValue: Currency): String;
+begin
+ Result := Format('%m', [AValue], UsedFormatSettings);
+end;
+
+function TCustomCurrSpinEditEx.StrToValue(const S: String): Currency;
+var
+ Def, N: Currency;
+begin
+ {$ifdef debug_editctrls}
+ debugln(['TCustomSpinEditEx.StrToValue: S="',S,'"']);
+ {$endif}
+ case FNullValueBehaviour of
+ nvbShowTextHint: Def := FNullValue;
+ nvbLimitedNullValue: Def := GetLimitedValue(FNullValue);
+ nvbMinValue: Def := FMinValue;
+ nvbMaxValue: Def := MaxValue;
+ nvbInitialValue: Def := FInitialValue;
+ end;
+ try
+ if (FNullValueBehaviour = nvbShowTextHint)then
+ begin
+ if TextIsNumber(S, N)
+ then
+ Result := N
+ else
+ Result := Def;
+ end
+ else
+ if TextIsNumber(S, N) then
+ Result := GetLimitedValue(N)
+ else
+ Result := Def
+// Result := GetLimitedValue(StrToCurrDef(S, Def));
+ except
+ Result := Def;
+ end;
+ {$ifdef debug_editctrls}
+ debugln([' Result=',(Result)]);
+ {$endif}
+end;
+
+
+end.
+