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

Question

我见过How to make a Delphi TSpeedButton stay pressed ...，但我希望它是TButton，因为它支持绘制字形（我的意思是Images、ImageIndex、HotImageIndex，...）。我知道我可以通过代码将它全部绘制出来，但我认为一定有什么技巧可以让它保持下来。

Answer 1

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

制作一个按钮（例如复选框、三态复选框或单选框） 按钮）的外观和行为就像一个按钮。按钮看起来凸起时 不推送或检查，推送或检查时下沉。

TCheckBox 和 TRadioButton 实际上都是标准 Windows BUTTON 控件的子类。 （这将提供类似于 .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 宏（向按钮控件发送 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;

注意：要使用此宏，您必须提供一个清单来指定 Comclt32.dll 6.0版

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

---

实际上，通过使用BS_PUSHLIKE + BS_CHECKBOX 样式将其转换为“复选框”并完全省略BS_PUSHBUTTON 样式，可以轻松地将逆方法直接应用于TButton。我从TCheckBox借了一点代码，并使用了一个interposer类进行演示：

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

这只是对kobik's detailed answer 的修改。我添加了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。