如何使 Delphi TButton 控件保持按下状态？

Question

我看过 How to make a Delphi TSpeedButton stay pressed ...，但我希望它是 TButton，因为它支持绘制字形的方式（我的意思是 Images、ImageIndex、HotImageIndex, ...)。我知道我可以通过代码绘制所有内容，但我认为一定有一些技巧可以让它保持下来。

Answer 1

您可以使用 TCheckbox 或 TRadioButton 来获得具有 BS_PUSHLIKE 样式的按钮外观。

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.

TCheckBox 和 TRadioButton 实际上都是 class 标准 Windows BUTTON 控件的子class。（这将提供类似于 .net CheckBox 的切换按钮行为，其中 Appearance 设置为 Button - 请参阅：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;

设置 Checked 属性是否按下。

要设置图像列表，请使用 Button_SetImageList macro (which sends a BCM_SETIMAGELIST 消息到按钮控件）例如：

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

每个 TButton 使用 它自己的 内部图像列表 (FInternalImageList)，每个按钮状态包含 5 张图像 (ImageIndex, HotImageIndex, ...)。因此，当您分配 ImageIndex 或 HotImageIndex 等时，它会重建该内部图像列表并使用它。如果只有一个图像存在，则它用于所有状态。如果需要，请参阅来源 TCustomButton.UpdateImages 以了解它是如何完成的，并为您的 TButtonCheckBox.

应用相同的逻辑

实际上，通过使用 BS_PUSHLIKE + BS_CHECKBOX 样式将 TButton 转换为 "check box" 并完全省略 BS_PUSHBUTTON 样式，可以轻松地将逆向方法直接应用于 TButton。我从 TCheckBox 那里借用了一些代码并使用了一个插入器 class 进行演示：

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;

现在，如果您将 PushLike 属性设置为 True，您可以使用 Checked 属性来切换按钮状态。

Answer 2

这只是对的修改。我添加了 GroupIndex 属性以使一组按钮协同工作（当 GroupIndex <> 0 时让其中一个按钮保持按下状态）。问题中甚至没有问到这样的设施，但我认为未来来这里的人可能很快就会需要它，就像我一样。我还删除了 PushLike 属性并假定它默认为 True，因为毕竟我将其命名为 TToggleButton。

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;

TurnSiblingsOff方法借鉴自TRadioButton。

如何使 Delphi TButton 控件保持按下状态？

How to make Delphi TButton control stay pressed?

delphi

delphi-2010

vcl