[solved] How to control checkbox colors

[Joanna from IRC]

I am making a new control
Tmycheckbox = class(tcheckbox)

Currently the checkbox interior is black and the check mark is yellow. How can I change these colors to better match the checkbox font and background colors? Also is there a way to control the color of box itself?

[lainz]

I am making a new control
Tmycheckbox = class(tcheckbox)

Currently the checkbox interior is black and the check mark is yellow. How can I change these colors to better match the checkbox font and background colors? Also is there a way to control the color of box itself?

Hi Joanna, you can use BGRAControls. There is TBGRAThemeCheckBox, you can drop a TBGRASVGTheme then and add the SVG images you want.

[Joanna from IRC]

Thanks lainz
That seems complicated To add an image I was hoping to just override the method that paints the checkbox or something

[Handoko]

... I was hoping to just override the method that paints the checkbox or something

No, you can't. TCheckBox depends heavily on the related OS' API.

If the OS does not provide such feature, not much you can do. Actually you could but only if you're really good in understanding how the OS/API works, so you might hack into and modify its default behavior but that is nearly impossible.

[Joanna from IRC]

No wonder I couldn’t find the code for drawing it. How about tcdcheckbox is it possible to change colors?

[Handoko]

Because TcdCheckBox does not depend on the OS' API.

Most of the default Lazarus components map/link to the OS' API. for example, Linux's API provides user to change button color but Windows does not. So TButton's color can be changed if it runs on Linux but not on Windows.

[lainz]

No wonder I couldn’t find the code for drawing it. How about tcdcheckbox is it possible to change colors?

Yes but you need to override a theme.

[lainz]

Thanks lainz
That seems complicated To add an image I was hoping to just override the method that paints the checkbox or something

Is just XML, is pasted as text in the editor.

To draw a checkbox just use Inkscape, is not that hard to draw with it, just like any other drawing program.

If Inkscape is too hard for you, you can try LazPaint.

[Joanna from IRC]

Thanks for the answers

[KodeZwerg]

... I was hoping to just override the method that paints the checkbox or something

No, you can't. TCheckBox depends heavily on the related OS' API.

If the OS does not provide such feature, not much you can do. Actually you could but only if you're really good in understanding how the OS/API works, so you might hack into and modify its default behavior but that is nearly impossible.

Your "nearly impossible" and "no you cant" catched my attention so here is just a proof-of-concept

Code: Pascal  [Select][+][-]

1.  uses ... LMessages, LCLType, LCLIntf ...
2.  
3. type
4.  
5.   { TCheckBox }
6.  
7.   TCheckBox = class(StdCtrls.TCheckBox)
8.     protected
9.       procedure WndProc(var Message: TLMessage); override;
10.   end;
11.  
12. implementation
13.  
14. procedure TCheckBox.WndProc(var Message: TLMessage);
15. var
16.   bmp: Graphics.TBitmap;
17.   DC: HDC;
18.   Canvas: TCanvas;
19. begin
20.   inherited;
21.  
22.   if Message.Msg = LM_PAINT then
23.     begin
24.       DC := GetDC(Handle);
25.       try
26.         Canvas := TCanvas.Create;
27.         try
28.           Canvas.Handle := DC;
29.           bmp := Graphics.TBitmap.Create;
30.           try
31.             bmp.PixelFormat := pf24bit;
32.             bmp.SetSize(13, 13);
33.             bmp.Canvas.Brush.Style := bsSolid;
34.             if Self.Color = clDefault then
35.               begin
36.                 bmp.Canvas.Brush.Color := Self.GetDefaultColor(dctBrush);
37.                 Canvas.Brush.Color := Self.GetDefaultColor(dctBrush);
38.               end
39.             else
40.               begin
41.                 bmp.Canvas.Brush.Color := Self.Color;
42.                 Canvas.Brush.Color := Self.Color;
43.               end;
44.             Canvas.FillRect(Canvas.ClipRect);
45.             bmp.Canvas.FillRect(bmp.Canvas.ClipRect);
46.             if Checked then
47.               bmp.Canvas.Brush.Color := clLime
48.             else
49.               bmp.Canvas.Brush.Color := clRed;
50.             bmp.Canvas.Pen.Style := psSolid;
51.             bmp.Canvas.Pen.Color := clBlack;
52.             bmp.Canvas.Pen.Width := 1;
53.             bmp.Canvas.Ellipse(bmp.Canvas.ClipRect);
54.             Canvas.Draw(2, (Canvas.Height - bmp.Height) div 2, bmp);
55.             Canvas.Font := Self.Font;
56.             Canvas.TextOut(16, (Canvas.Height - Canvas.TextHeight(Self.Caption)) div 2, Self.Caption);
57.           finally
58.             bmp.Free;
59.           end;
60.         finally
61.           Canvas.Free;
62.         end;
63.       finally
64.         ReleaseDC(Handle, DC);
65.       end;
66.     end;
67. end;

Lazarus 3.99 (rev main_3_99-1993-g5ad1922ccb) FPC 3.2.2 x86_64-win64-win32/win64

// updated sample that it actual use the "Color" property as background and "Font.Color" for the caption.

[Handoko]

Nice!

You're the minority that can make nearly impossible things to happen.

[KodeZwerg]

Nice!

You're the minority that can make nearly impossible things to happen.

  Thanks, I tried to make the component transparent but currently failed, I assume I would need to hop on LM_CREATE to make it happen

anyway, here is my latest revision, its more clean now and prepared for transparency, interception works for both ways same, if control is on form or within a container like TPanel.
many things missing like mouse over events with a different border around circle.

Code: Pascal  [Select][+][-]

1. type
2.  
3.   { TCheckBox }
4.  
5.   TCheckBox = class(StdCtrls.TCheckBox)
6.     strict private
7.       FTransparent: Boolean;
8.       FMouseOver: Boolean;
9.     private
10.       procedure SetTransparent(const AValue: Boolean);
11.       procedure CreateImage(var AImage: TCustomBitmap);
12.     protected
13.       procedure WndProc(var Message: TLMessage); override;
14.       procedure MouseEnter; override;
15.       procedure MouseLeave; override;
16.     public
17.     published
18.       property Transparent: Boolean read FTransparent write SetTransparent stored True default False;
19.   end;

Code: Pascal  [Select][+][-]

1. procedure TCheckBox.WndProc(var Message: TLMessage);
2. var
3.   LBitmap: TCustomBitmap;
4.   LDC: HDC;
5.   LCanvas: TCanvas;
6. begin
7.   inherited;
8.   case Message.Msg of
9.     LM_DESTROY: begin // LM_DESTROY
10.                 end; // LM_DESTROY
11.     LM_PAINT: begin // LM_PAINT
12.                   LCanvas := TCanvas.Create;
13.                   try
14.                     LDC := GetDC(Self.Handle);
15.                     try
16.                       LCanvas.Handle := LDC;
17.                       CreateImage(LBitmap{%H-});
18.                       try
19.                         LCanvas.Draw(0, 0, LBitmap);
20.                       finally
21.                         LBitmap.Free;
22.                       end;
23.                     finally
24.                       ReleaseDC(Self.Handle, LDC);
25.                     end;
26.                   finally
27.                     LCanvas.Free;
28.                   end;
29.               end; // LM_PAINT
30.     end; // case Message.Msg of
31. end;
32.  
33. procedure TCheckBox.SetTransparent(const AValue: Boolean);
34. begin
35.   if FTransparent = AValue then
36.     Exit;
37.   FTransparent := AValue;
38.   Self.Invalidate;
39. end;
40.  
41. procedure TCheckBox.CreateImage(var AImage: TCustomBitmap);
42. var
43.   LBitmap: TCustomBitmap;
44.   LBackground: TColor;
45.   LRect: TRect;
46. begin
47.   // setup background color
48.   if Self.Color = clDefault then
49.     LBackground := Self.GetDefaultColor(dctBrush)
50.   else
51.     LBackground := Self.Color;
52.   // create image to paint on
53.   LBitmap := Graphics.TCustomBitmap.Create{%H-};
54.   try
55.     // setup defaults
56.     LBitmap.SetSize(Self.ClientWidth, Self.ClientHeight);
57.     LBitmap.Canvas.AntialiasingMode := amDontCare; //amOn;
58.     LBitmap.Canvas.CopyMode := cmSrcCopy;
59.     // setup font
60.     LBitmap.Canvas.Font := Self.Font;
61.     if Self.Font.Color = clDefault then
62.       LBitmap.Canvas.Font.Color := Self.GetDefaultColor(dctFont);
63.     // alpha test: transparency
64.     // does not work :D (LBitmap is transparent but the control is not)
65.     // currently it would let original CheckBox painting shine thru
66.     if FTransparent then
67.       begin
68.         LBitmap.TransparentMode := tmFixed;
69.         LBitmap.TransparentColor := LBackground;
70.         LBitmap.Transparent := True;
71.       end;
72.     // setup initial canvas values
73.     LBitmap.Canvas.Brush.Color := LBackground;
74.     LBitmap.Canvas.Brush.Style := bsSolid;
75.     LBitmap.Canvas.Pen.Style := psSolid;
76.     // add small effect when the mouse is over the control
77.     if FMouseOver then
78.       LBitmap.Canvas.Pen.Color := clBtnHighlight
79.     else
80.       LBitmap.Canvas.Pen.Color := clBlack;
81.     LBitmap.Canvas.Pen.Width := 1;
82.     // clear image
83.     LBitmap.Canvas.FillRect(LBitmap.Canvas.ClipRect);
84.     // prepare circle coordinates
85.     LRect.Top := (LBitmap.Canvas.Height - 13) div 2;
86.     if (Self.Alignment = taRightJustify) and (Self.BiDiMode <> bdRightToLeft) then
87.       LRect.Left := 2;
88.     if (
89.         ((Self.Alignment = taRightJustify) and (Self.BiDiMode = bdRightToLeft))
90.         or
91.         ((Self.Alignment = taLeftJustify) and (Self.BiDiMode = bdRightToLeft))
92.         or
93.         ((Self.Alignment = taLeftJustify) and (Self.BiDiMode = bdLeftToRight))
94.         )
95.        then
96.       LRect.Left := LBitmap.Canvas.ClipRect.Width - 15;
97.     LRect.Right := LRect.Left + 13;
98.     LRect.Bottom := LRect.Top + 13;
99.     // choose color by current state
100.     if Self.Checked or (Self.State = cbChecked) then
101.       LBitmap.Canvas.Brush.Color := clLime;
102.     if (not Self.Checked) or (Self.State = cbUnchecked) then
103.       LBitmap.Canvas.Brush.Color := clRed;
104.     if (Self.State = cbGrayed) then
105.       LBitmap.Canvas.Brush.Color := clMedGray;
106.     LBitmap.Canvas.Ellipse(LRect);
107.     // prepare color and write text
108.     LBitmap.Canvas.Brush.Color := LBackground;
109.     if (Self.Alignment = taRightJustify) and (Self.BiDiMode <> bdRightToLeft) then
110.       LBitmap.Canvas.TextOut(16, (LBitmap.Canvas.Height - LBitmap.Canvas.TextHeight(Self.Caption)) div 2, Self.Caption)
111.     else
112.       LBitmap.Canvas.TextOut(1, (LBitmap.Canvas.Height - LBitmap.Canvas.TextHeight(Self.Caption)) div 2, Self.Caption);
113.     // when focused draw a rectangle around
114.     if Self.Focused then
115.       begin
116.         LBitmap.Canvas.Brush.Color := clActiveCaption;
117.         LBitmap.Canvas.FrameRect(LBitmap.Canvas.ClipRect);
118.       end;
119.     // transport image
120.     AImage := TCustomBitmap.Create;
121.     AImage.Assign(LBitmap);
122.   finally
123.     LBitmap.Free;
124.   end;
125. end;
126.  
127. procedure TCheckBox.MouseEnter;
128. begin
129.   FMouseOver := True;
130.   inherited MouseEnter;
131. end;
132.  
133. procedure TCheckBox.MouseLeave;
134. begin
135.   FMouseOver := False;
136.   inherited MouseLeave;
137. end;

//updated
now it reacts visual when mouse is over
bidi/alignment supported
gray possibility included
custom focus rectangle added
removed the draw routines from OnPaint

[lainz]

That code works in any platform? Just asking because I dont' know...

[KodeZwerg]

That code works in any platform? Just asking because I dont' know...

I am no crossplatform expert but crosscompile units are used.
Attached is a simple demo project where TCheckBox gets intercepted.

Tested successful with Lazarus 3.99 (rev main_3_99-1993-g5ad1922ccb) FPC 3.2.2 x86_64-win64-win32/win64

[Joanna from IRC]

Thanks kodezwerg
Is it possible to have a colored checkbox that looks more like the standard checkbox though?