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

Question

我看到了一个关于如何让Delphi的TSpeedButton保持按下状态的问题（How to make a Delphi TSpeedButton stay pressed ...），但是由于它支持绘制图标（即Images、ImageIndex、HotImageIndex等），我希望使用TButton。我知道可以通过代码来实现所有的绘制，但我认为一定有一些技巧可以使它保持按下状态。

- saastn

---

不好意思，TButton 没有“按下”状态。 - David Heffernan

{btsdaf} - saastn

这不是如何做的问题，而是是否可能的问题，David已经告诉你三次了，它是不可能的。你需要编写自己的代码来模仿它，因为它不是Windows API原生支持的。你肯定不希望我们为你编写一个自定义控件，对吧？TSpeedButton <> TButton。 - Jerry Dodge

"SendMessage(Button.Handle, BM_SETSTATE, BST_PUSHED, LPARAM(True));" 是一个API函数调用，目的是将按钮设为“按下”状态。该函数会使按钮看起来好像被按下并高亮显示。由于按钮只有在成为活动控件时才处于按下状态，因此您可能不希望在页面上出现太多看起来活跃的按钮。请注意，这里只提供翻译，不包括解释或任何其他内容。 - Sertac Akyuz

@SertacAkyuz，但是你如何通过单击按钮来实际切换按钮状态呢？ - kobik

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样式直接将TButton变为“复选框”，并完全省略BS_PUSHBUTTON样式来轻松应用反向方法。我从TCheckBox借鉴了一些代码，并使用中介类进行演示。

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 属性来切换按钮状态。

- kobik

---

这正是我所需要的，并且在10.1 Berlin中运行得非常好。我明天会在D2010中检查它。非常感谢您详细的回答。 - saastn

Answer 2

这只是对 kobik 的详细答案 的修改。我添加了 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。

- saastn