I've seen How to make a Delphi TSpeedButton stay pressed ..., but I want it to be TButton
because of the way it supports drawing glyph (I mean Images
, ImageIndex
, HotImageIndex
, ...). I know that I can draw it all by code, but I thought there must be some trick that makes it stay down.
You can use a TCheckbox
or a TRadioButton
to have an appearance of a Button with the BS_PUSHLIKE
style.
Makes a button (such as a check box, three-state check box, or radio button) look and act like a push button. The button looks raised when it isn't pushed or checked, and sunken when it is pushed or checked.
Both TCheckBox
and TRadioButton
are actually sub-classed from the standard Windows BUTTON
control. (This will give a toggle button behavior similar to .net CheckBox
with Appearance
set to Button - see: Do we have Button down property as Boolean).
type
TButtonCheckBox = class(StdCtrls.TCheckBox)
protected
procedure CreateParams(var Params: TCreateParams); override;
end;
procedure TButtonCheckBox.CreateParams(var Params: TCreateParams);
begin
inherited CreateParams(Params);
Params.Style := Params.Style or BS_PUSHLIKE;
end;
Set the Checked
property to make it pressed or not.
To set an image list use Button_SetImageList
macro (which sends a BCM_SETIMAGELIST
message to the button control) e.g.:
uses CommCtrl;
...
procedure TButtonCheckBox.SetImages(const Value: TCustomImageList);
var
LButtonImageList: TButtonImageList;
begin
LButtonImageList.himl := Value.Handle;
LButtonImageList.uAlign := BUTTON_IMAGELIST_ALIGN_LEFT;
LButtonImageList.margin := Rect(4, 0, 0, 0);
Button_SetImageList(Handle, LButtonImageList);
Invalidate;
end;
Note: To use this macro, you must provide a manifest specifying Comclt32.dll version 6.0
Each TButton
uses it's own internal image list (FInternalImageList
) that holds 5 images for each button state (ImageIndex
, HotImageIndex
, ...).
So when you assign an ImageIndex
or HotImageIndex
etc, it rebuilds that internal image list, and uses that. If only one image is present, it is used for all states.
If needed, see source TCustomButton.UpdateImages
to learn how it's done, and apply the same logic for your TButtonCheckBox
.
Actually the inverse method could be easily applied directly to a TButton
by turning it into a "check box" using BS_PUSHLIKE + BS_CHECKBOX
styles, and omitting the BS_PUSHBUTTON
style completely. I borrowed a bit of code from TCheckBox
and used an interposer class for demo:
type
TButton = class(StdCtrls.TButton)
private
FChecked: Boolean;
FPushLike: Boolean;
procedure SetPushLike(Value: Boolean);
procedure Toggle;
procedure CNCommand(var Message: TWMCommand); message CN_COMMAND;
protected
procedure SetButtonStyle(ADefault: Boolean); override;
procedure CreateParams(var Params: TCreateParams); override;
procedure CreateWnd; override;
function GetChecked: Boolean; override;
procedure SetChecked(Value: Boolean); override;
published
property Checked;
property PushLike: Boolean read FPushLike write SetPushLike;
end;
implementation
procedure TButton.SetButtonStyle(ADefault: Boolean);
begin
if not FPushLike then inherited;
{ Else, do nothing - avoid setting style to BS_PUSHBUTTON }
end;
procedure TButton.CreateParams(var Params: TCreateParams);
begin
inherited CreateParams(Params);
if FPushLike then
begin
Params.Style := Params.Style or BS_PUSHLIKE or BS_CHECKBOX;
Params.WindowClass.style := Params.WindowClass.style and not (CS_HREDRAW or CS_VREDRAW);
end;
end;
procedure TButton.CreateWnd;
begin
inherited CreateWnd;
if FPushLike then
SendMessage(Handle, BM_SETCHECK, Integer(FChecked), 0);
end;
procedure TButton.CNCommand(var Message: TWMCommand);
begin
if FPushLike and (Message.NotifyCode = BN_CLICKED) then
Toggle
else
inherited;
end;
procedure TButton.Toggle;
begin
Checked := not FChecked;
end;
function TButton.GetChecked: Boolean;
begin
Result := FChecked;
end;
procedure TButton.SetChecked(Value: Boolean);
begin
if FChecked <> Value then
begin
FChecked := Value;
if FPushLike then
begin
if HandleAllocated then
SendMessage(Handle, BM_SETCHECK, Integer(Checked), 0);
if not ClicksDisabled then Click;
end;
end;
end;
procedure TButton.SetPushLike(Value: Boolean);
begin
if Value <> FPushLike then
begin
FPushLike := Value;
RecreateWnd;
end;
end;
Now if you set PushLike
property to True
, you can use the Checked
property to toggle the button state.
This is just a modification to kobik's detailed answer. I added GroupIndex
property to make a group of buttons work together (let only one of them stay down at a time when GroupIndex <> 0
). Such facility was not even asked in the question, but I thought people who come here in the future may need it soon after, just like I did. I also removed PushLike
property and assumed it to be True
by default, since I named it the TToggleButton
after all.
uses
Winapi.Windows, Vcl.StdCtrls, Winapi.Messages, Vcl.Controls, Vcl.ActnList;
type
TToggleButton = class(TButton)
private
FChecked: Boolean;
FGroupIndex: Integer;
procedure Toggle;
procedure CNCommand(var Message: TWMCommand); message CN_COMMAND;
procedure SetGroupIndex(const Value: Integer);
procedure TurnSiblingsOff;
protected
procedure SetButtonStyle(ADefault: Boolean); override;
procedure CreateParams(var Params: TCreateParams); override;
procedure CreateWnd; override;
function GetChecked: Boolean; override;
procedure SetChecked(Value: Boolean); override;
published
property Checked;
property GroupIndex: Integer read FGroupIndex write SetGroupIndex;
end;
implementation
{ TToggleButton}
procedure TToggleButton.SetButtonStyle(ADefault: Boolean);
begin
{ do nothing - avoid setting style to BS_PUSHBUTTON }
end;
procedure TToggleButton.CreateParams(var Params: TCreateParams);
begin
inherited CreateParams(Params);
Params.Style := Params.Style or BS_PUSHLIKE or BS_CHECKBOX;
Params.WindowClass.style := Params.WindowClass.style and not (CS_HREDRAW or CS_VREDRAW);
end;
procedure TToggleButton.CreateWnd;
begin
inherited CreateWnd;
SendMessage(Handle, BM_SETCHECK, Integer(FChecked), 0);
end;
procedure TToggleButton.CNCommand(var Message: TWMCommand);
begin
if Message.NotifyCode = BN_CLICKED then
Toggle
else
inherited;
end;
procedure TToggleButton.Toggle;
begin
Checked := not FChecked;
end;
function TToggleButton.GetChecked: Boolean;
begin
Result := FChecked;
end;
procedure TToggleButton.SetChecked(Value: Boolean);
begin
if FChecked <> Value then
begin
FChecked := Value;
if HandleAllocated then
SendMessage(Handle, BM_SETCHECK, Integer(Checked), 0);
if Value then
TurnSiblingsOff;
if not ClicksDisabled then Click;
end;
end;
procedure TToggleButton.SetGroupIndex(const Value: Integer);
begin
FGroupIndex := Value;
if Checked then
TurnSiblingsOff;
end;
procedure TToggleButton.TurnSiblingsOff;
var
I: Integer;
Sibling: TControl;
begin
if (Parent <> nil) and (GroupIndex <> 0) then
with Parent do
for I := 0 to ControlCount - 1 do
begin
Sibling := Controls[I];
if (Sibling <> Self) and (Sibling is TToggleButton) then
with TToggleButton(Sibling) do
if GroupIndex = Self.GroupIndex then
begin
if Assigned(Action) and
(Action is TCustomAction) and
TCustomAction(Action).AutoCheck then
TCustomAction(Action).Checked := False;
SetChecked(False);
end;
end;
end;
The TurnSiblingsOff
method is borrowed from TRadioButton
.
If you love us? You can donate to us via Paypal or buy me a coffee so we can maintain and grow! Thank you!
Donate Us With