自定义组件-支持PNG图片的多态GraphicButton

按钮功能使用TButton也可以解决, 但是TButton是会获得焦点的, 很多时候我们要求按钮不获得焦点, 而Speedbutton又不支持PNG图片

所以按照TSpeedbutton的代码, 重新封装了一个:

unit HSImageButton;

//  ***************************************************************************
//
//  支持PNG的Graphicbutton
//
//  版本: 1.0
//  作者: 刘志林
//  修改日期: 2016-07-12
//  QQ: 17948876
//  E-mail: lzl_17948876@hotmail.com
//  博客: http://www.cnblogs.com/lzl_17948876/
//
//  !!! 若有修改,请通知作者,谢谢合作 !!!
//
//  ---------------------------------------------------------------------------
//
//  说明:
//    1.通过绑定ImageList来显示图标
//    2.通过Imagelist对PNG的支持来显示PNG图标
//    3.支持4种状态切换 (Normal/Hot/Pressed/Disabled)
//    4.支持图片位置排列 (ImageAlignment)
//    5.支持SpeedButton的Group模式
//    6.版本兼容至D2010
//
//  ***************************************************************************

interface

uses
  System.Classes, System.SysUtils, System.Types,
{$IF RTLVersion >= 29}
  System.ImageList,
{$ENDIF}
  Winapi.Messages, Winapi.Windows,
  Vcl.Controls, Vcl.StdCtrls, Vcl.Buttons, Vcl.Graphics, Vcl.Forms,
  Vcl.Themes, Vcl.ImgList, Vcl.ActnList;

type
  THSImageButton = class;

  THSImageButtonActionLink = class(TControlActionLink)
  protected
    FClient: THSImageButton;
    procedure AssignClient(AClient: TObject); override;
    function IsCheckedLinked: Boolean; override;
    function IsGroupIndexLinked: Boolean; override;
    function IsImageIndexLinked: Boolean; override;
    procedure SetGroupIndex(Value: Integer); override;
    procedure SetChecked(Value: Boolean); override;
    procedure SetImageIndex(Value: Integer); override;
  public
    constructor Create(AClient: TObject); override;
  end;

  THSImageButtonActionLinkClass = class of THSImageButtonActionLink;

  THSImageButton = class(TGraphicControl)
  private
    FGroupIndex: Integer;
    FDown: Boolean;
    FDragging: Boolean;
    FAllowAllUp: Boolean;
    FSpacing: Integer;
    FTransparent: Boolean;
    FMargin: Integer;
    FFlat: Boolean;
    FMouseInControl: Boolean;
    FImageAlignment: TImageAlignment;
    FImages: TCustomImageList;
    FImageMargins: TImageMargins;

    FImageIndex: TImageIndex;
    FPressedImageIndex: TImageIndex;
    FDisabledImageIndex: TImageIndex;
    FHotImageIndex: TImageIndex;

    FImageChangeLink: TChangeLink;
    procedure GlyphChanged(Sender: TObject);
    procedure UpdateExclusive;
    procedure SetDown(Value: Boolean);
    procedure SetFlat(Value: Boolean);
    procedure SetAllowAllUp(Value: Boolean);
    procedure SetGroupIndex(Value: Integer);
    procedure SetSpacing(Value: Integer);
    procedure SetTransparent(Value: Boolean);
    procedure SetMargin(Value: Integer);
    procedure UpdateTracking;
    procedure WMLButtonDblClk(var Message: TWMLButtonDblClk); message WM_LBUTTONDBLCLK;
    procedure CMEnabledChanged(var Message: TMessage); message CM_ENABLEDCHANGED;
    procedure CMDialogChar(var Message: TCMDialogChar); message CM_DIALOGCHAR;
    procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED;
    procedure CMTextChanged(var Message: TMessage); message CM_TEXTCHANGED;
    procedure CMMouseEnter(var Message: TMessage); message CM_MOUSEENTER;
    procedure CMMouseLeave(var Message: TMessage); message CM_MOUSELEAVE;
    procedure CMButtonPressed(var Message: TMessage); message CM_BUTTONPRESSED;
    procedure SetImageAlignment(const Value: TImageAlignment);
    procedure SetImageIndex(const Value: TImageIndex);
    procedure SetImageMargins(const Value: TImageMargins);
    procedure SetImages(const Value: TCustomImageList);
    procedure SetDisabledImageIndex(const Value: TImageIndex);
    procedure SetHotImageIndex(const Value: TImageIndex);
    procedure SetPressedImageIndex(const Value: TImageIndex);
  protected
    FState: TButtonState;
    procedure Notification(AComponent: TComponent; Operation: TOperation); override;
    procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override;
    function GetActionLinkClass: TControlActionLinkClass; override;
    procedure Loaded; override;
    procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
      X, Y: Integer); override;
    procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
    procedure MouseUp(Button: TMouseButton; Shift: TShiftState;
      X, Y: Integer); override;
    procedure Paint; override;
    property MouseInControl: Boolean read FMouseInControl;
    procedure ImageMarginsChange(Sender: TObject);
    procedure ImageListChange(Sender: TObject);
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Click; override;
  published
    property Action;
    property Align;
    property AllowAllUp: Boolean read FAllowAllUp write SetAllowAllUp default False;
    property Anchors;
    property BiDiMode;
    property Constraints;
    property GroupIndex: Integer read FGroupIndex write SetGroupIndex default 0;
    property Down: Boolean read FDown write SetDown default False;
    property Caption;
    property Enabled;
    property Flat: Boolean read FFlat write SetFlat default False;
    property Font;
    property Images: TCustomImageList read FImages write SetImages;
    property ImageAlignment: TImageAlignment read FImageAlignment write SetImageAlignment default iaLeft;
    property ImageIndex: TImageIndex read FImageIndex write SetImageIndex default -1;
    property HotImageIndex: TImageIndex read FHotImageIndex write SetHotImageIndex default -1;
    property PressedImageIndex: TImageIndex read FPressedImageIndex write SetPressedImageIndex default -1;
    property DisabledImageIndex: TImageIndex read FDisabledImageIndex write SetDisabledImageIndex default -1;
    property ImageMargins: TImageMargins read FImageMargins write SetImageMargins;
    property Margin: Integer read FMargin write SetMargin default -1;
    property ParentFont;
    property ParentShowHint;
    property ParentBiDiMode;
    property PopupMenu;
    property ShowHint;
    property Spacing: Integer read FSpacing write SetSpacing default 4;
    property Transparent: Boolean read FTransparent write SetTransparent default True;
    property Visible;
    property StyleElements;
    property OnClick;
    property OnDblClick;
    property OnMouseActivate;
    property OnMouseDown;
    property OnMouseEnter;
    property OnMouseLeave;
    property OnMouseMove;
    property OnMouseUp;
  end;

implementation

{ THSImageButton }

constructor THSImageButton.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  SetBounds(0, 0, 23, 22);
  ControlStyle := [csCaptureMouse, csDoubleClicks];
  ParentFont := True;
  Color := clBtnFace;
  FSpacing := 4;
  FMargin := -1;
  FTransparent := True;
  FImageIndex := -1;
  FDisabledImageIndex := -1;
  FPressedImageIndex := -1;
  FHotImageIndex := -1;
  FImageMargins := TImageMargins.Create;
  FImageMargins.OnChange := ImageMarginsChange;
  FImageChangeLink := TChangeLink.Create;
  FImageChangeLink.OnChange := ImageListChange;
end;

destructor THSImageButton.Destroy;
begin
  FreeAndNil(FImageChangeLink);
  FreeAndNil(FImageMargins);
  inherited Destroy;
end;

const
  DownStyles: array[Boolean] of Integer = (BDR_RAISEDINNER, BDR_SUNKENOUTER);
  FillStyles: array[Boolean] of Integer = (BF_MIDDLE, 0);

procedure THSImageButton.Paint;

  function DoGlassPaint: Boolean;
  var
    nLParent: TWinControl;
  begin
    Result := csGlassPaint in ControlState;
    if Result then
    begin
      nLParent := Parent;
      while (nLParent <> nil) and not nLParent.DoubleBuffered do
        nLParent := nLParent.Parent;
      Result := (nLParent = nil) or not nLParent.DoubleBuffered or (nLParent is TCustomForm);
    end;
  end;

var
  nPaintRect, nTextRect: TRect;
  nDrawFlags, nImageIndex: Integer;
  nOffset, nTmpPoint: TPoint;
  nLGlassPaint: Boolean;
  nTMButton: TThemedButton;
  nTMToolBar: TThemedToolBar;
  nDetails: TThemedElementDetails;
  nLStyle: TCustomStyleServices;
  nLColor: TColor;
  nLFormats: TTextFormat;
  nTextFlg: DWORD;
{$IF RTLVersion >= 27}
  nDefGrayscaleFactor: Byte;
{$ENDIF}
begin
  {Copy As TSpeedButton.Paint}
  if not Enabled then
  begin
    FState := bsDisabled;
    FDragging := False;
  end
  else if FState = bsDisabled then
    if FDown and (GroupIndex <> 0) then
      FState := bsExclusive
    else
      FState := bsUp;
  Canvas.Font := Self.Font;
  Canvas.Brush.Style := bsClear;

  if ThemeControl(Self) then
  begin
    nLGlassPaint := DoGlassPaint;
    if not nLGlassPaint then
      if Transparent then
        StyleServices.DrawParentBackground(0, Canvas.Handle, nil, True)
      else
        PerformEraseBackground(Self, Canvas.Handle)
    else
      FillRect(Canvas.Handle, ClientRect, GetStockObject(BLACK_BRUSH));

    if not Enabled then
      nTMButton := tbPushButtonDisabled
    else
      if FState in [bsDown, bsExclusive] then
        nTMButton := tbPushButtonPressed
      else
        if MouseInControl then
          nTMButton := tbPushButtonHot
        else
          nTMButton := tbPushButtonNormal;

    nTMToolBar := ttbToolbarDontCare;
    if FFlat or TStyleManager.IsCustomStyleActive then
    begin
      case nTMButton of
        tbPushButtonDisabled:
          nTMToolBar := ttbButtonDisabled;
        tbPushButtonPressed:
          nTMToolBar := ttbButtonPressed;
        tbPushButtonHot:
          nTMToolBar := ttbButtonHot;
        tbPushButtonNormal:
          nTMToolBar := ttbButtonNormal;
      end;
    end;
    nPaintRect := ClientRect;
    if nTMToolBar = ttbToolbarDontCare then
    begin
      nDetails := StyleServices.GetElementDetails(nTMButton);
      StyleServices.DrawElement(Canvas.Handle, nDetails, nPaintRect);
      StyleServices.GetElementContentRect(Canvas.Handle, nDetails, nPaintRect, nPaintRect);
    end
    else
    begin
      nDetails := StyleServices.GetElementDetails(nTMToolBar);
      if not TStyleManager.IsCustomStyleActive then
      begin
        StyleServices.DrawElement(Canvas.Handle, nDetails, nPaintRect);
        // Windows theme services doesn't paint disabled toolbuttons
        // with grayed text (as it appears in an actual toolbar). To workaround,
        // retrieve nDetails for a disabled nTMButton for drawing the caption.
        if (nTMToolBar = ttbButtonDisabled) then
          nDetails := StyleServices.GetElementDetails(nTMButton);
      end
      else
      begin
        // Special case for flat speedbuttons with custom styles. The assumptions
        // made about the look of ToolBar buttons may not apply, so only paint
        // the hot and pressed states , leaving normal/disabled to appear flat.
        if not FFlat or ((nTMButton = tbPushButtonPressed) or (nTMButton = tbPushButtonHot)) then
          StyleServices.DrawElement(Canvas.Handle, nDetails, nPaintRect);
      end;
      StyleServices.GetElementContentRect(Canvas.Handle, nDetails, nPaintRect, nPaintRect);
    end;

    nOffset := Point(0, 0);
    if nTMButton = tbPushButtonPressed then
    begin
      // A pressed "flat" speed nTMButton has white text in XP, but the Themes
      // API won't render it as such, so we need to hack it.
      if (nTMToolBar <> ttbToolbarDontCare) and not CheckWin32Version(6) then
        Canvas.Font.Color := clHighlightText
      else
        if FFlat then
          nOffset := Point(1, 0);
    end;
  end
  else
  begin
    nPaintRect := Rect(1, 1, Width - 1, Height - 1);
    if not FFlat then
    begin
      nDrawFlags := DFCS_BUTTONPUSH or DFCS_ADJUSTRECT;
      if FState in [bsDown, bsExclusive] then
        nDrawFlags := nDrawFlags or DFCS_PUSHED;
      DrawFrameControl(Canvas.Handle, nPaintRect, DFC_BUTTON, nDrawFlags);
    end
    else
    begin
      if (FState in [bsDown, bsExclusive]) or
        (FMouseInControl and (FState <> bsDisabled)) or
        (csDesigning in ComponentState) then
        DrawEdge(Canvas.Handle, nPaintRect, DownStyles[FState in [bsDown, bsExclusive]],
          FillStyles[Transparent] or BF_RECT)
      else if not Transparent then
      begin
        Canvas.Brush.Color := Color;
        Canvas.FillRect(nPaintRect);
      end;
      InflateRect(nPaintRect, -1, -1);
    end;
    if FState in [bsDown, bsExclusive] then
    begin
      if (FState = bsExclusive) and (not FFlat or not FMouseInControl) then
      begin
        Canvas.Brush.Bitmap := AllocPatternBitmap(clBtnFace, clBtnHighlight);
        Canvas.FillRect(nPaintRect);
      end;
      nOffset.X := 1;
      nOffset.Y := 1;
    end
    else
    begin
      nOffset.X := 0;
      nOffset.Y := 0;
    end;

    nLStyle := StyleServices;
  end;

  nTextRect := ClientRect;
  nPaintRect := ClientRect;
  nPaintRect := Rect(nPaintRect.Left + FImageMargins.Left + 1,
    nPaintRect.Top + FImageMargins.Top + 1,
    nPaintRect.Right - FImageMargins.Right - 1,
    nPaintRect.Bottom - FImageMargins.Bottom - 1);
  if Images <> nil then
  begin
{$IF RTLVersion >= 27}
    nDefGrayscaleFactor := Images.GrayscaleFactor;
    Images.GrayscaleFactor := $FF;
{$ENDIF}
    nTmpPoint := nPaintRect.CenterPoint;
    case FImageAlignment of
      iaLeft:
      begin
        nTextRect.Left := nPaintRect.Left + Images.Width;
        nTmpPoint := Point(nPaintRect.Left, nPaintRect.Top + (nPaintRect.Height - Images.Height) div 2);
      end;
      iaRight:
      begin
        nTextRect.Right := nPaintRect.Right - Images.Width;
        nTmpPoint := Point(nTextRect.Right, nPaintRect.Top + (nPaintRect.Height - Images.Height) div 2);
      end;
      iaTop:
      begin
        nTextRect.Top := nPaintRect.Top + Images.Height;
        nTmpPoint := Point(nPaintRect.Left + (nPaintRect.Width - Images.Width) div 2, nPaintRect.Top);
      end;
      iaBottom:
      begin
        nTextRect.Bottom := nPaintRect.Bottom - Images.Height;
        nTmpPoint := Point(nPaintRect.Left + (nPaintRect.Width - Images.Width) div 2, nTextRect.Bottom);
      end;
      iaCenter:
      begin
        nTmpPoint := Point(nPaintRect.Left + (nPaintRect.Width - Images.Width) div 2,
          nPaintRect.Top + (nPaintRect.Height - Images.Height) div 2);
      end;
    end;

    if not Enabled then
    begin
      if FDisabledImageIndex > -1 then
        Images.Draw(Canvas, nTmpPoint.X, nTmpPoint.Y, FDisabledImageIndex, True)
      else
        Images.Draw(Canvas, nTmpPoint.X, nTmpPoint.Y, FImageIndex, False);
    end
    else
    begin
      if FState in [bsDown, bsExclusive] then
        nImageIndex := FPressedImageIndex
      else if MouseInControl then
        nImageIndex := FHotImageIndex
      else
        nImageIndex := FImageIndex;
      if nImageIndex = -1 then
        nImageIndex := FImageIndex;
      Images.Draw(Canvas, nTmpPoint.X, nTmpPoint.Y, nImageIndex, True);
    end;
{$IF RTLVersion >= 27}
    Images.GrayscaleFactor := nDefGrayscaleFactor;
{$ENDIF}
  end;

  nTextFlg := DT_VCENTER or DT_SINGLELINE or DT_CENTER;
  {Copy As TButtonGlyphc.DrawButtonText.DoDrawText}
  if ThemeControl(Self) then
  begin
    if (FState = bsDisabled) or (not StyleServices.IsSystemStyle and (seFont in StyleElements)) then
    begin
      if not StyleServices.GetElementColor(nDetails, ecTextColor, nLColor) or (nLColor = clNone) then
        nLColor := Canvas.Font.Color;
    end
    else
      nLColor := Canvas.Font.Color;

    nLFormats := TTextFormatFlags(nTextFlg);
    if nLGlassPaint then
      Include(nLFormats, tfComposited);
    StyleServices.DrawText(Canvas.Handle, nDetails, Text, nTextRect, nLFormats, nLColor);
  end
  else
  begin
    if FState = bsDisabled then
      Canvas.Font.Color := clGrayText
    else
      Canvas.Font.Color := clWindowText;
    Winapi.Windows.DrawText(Canvas.Handle, Text, Length(Text), nTextRect, nTextFlg);
  end;
end;

procedure THSImageButton.UpdateTracking;
var
  P: TPoint;
begin
  if FFlat then
  begin
    if Enabled then
    begin
      GetCursorPos(P);
      FMouseInControl := not (FindDragTarget(P, True) = Self);
      if FMouseInControl then
        Perform(CM_MOUSELEAVE, 0, 0)
      else
        Perform(CM_MOUSEENTER, 0, 0);
    end;
  end;
end;

procedure THSImageButton.Loaded;
var
  State: TButtonState;
begin
  inherited Loaded;
  if Enabled then
    State := bsUp
  else
    State := bsDisabled;
end;

procedure THSImageButton.MouseDown(Button: TMouseButton; Shift: TShiftState;
  X, Y: Integer);
begin
  inherited MouseDown(Button, Shift, X, Y);
  if (Button = mbLeft) and Enabled then
  begin
    if not FDown then
    begin
      FState := bsDown;
      Invalidate;
    end;
    FDragging := True;
  end;
end;

procedure THSImageButton.MouseMove(Shift: TShiftState; X, Y: Integer);
var
  NewState: TButtonState;
begin
  inherited MouseMove(Shift, X, Y);
  if FDragging then
  begin
    if not FDown then NewState := bsUp
    else NewState := bsExclusive;
    if (X >= 0) and (X < ClientWidth) and (Y >= 0) and (Y <= ClientHeight) then
      if FDown then NewState := bsExclusive else NewState := bsDown;
    if NewState <> FState then
    begin
      FState := NewState;
      Invalidate;
    end;
  end
  else if not FMouseInControl then
    UpdateTracking;
end;

procedure THSImageButton.MouseUp(Button: TMouseButton; Shift: TShiftState;
  X, Y: Integer);
var
  DoClick: Boolean;
begin
  inherited MouseUp(Button, Shift, X, Y);
  if FDragging then
  begin
    FDragging := False;
    DoClick := (X >= 0) and (X < ClientWidth) and (Y >= 0) and (Y <= ClientHeight);
    if FGroupIndex = 0 then
    begin
      { Redraw face in-case mouse is captured }
      FState := bsUp;
      FMouseInControl := False;
      if DoClick and not (FState in [bsExclusive, bsDown]) then
        Invalidate;
    end
    else
      if DoClick then
      begin
        SetDown(not FDown);
        if FDown then Repaint;
      end
      else
      begin
        if FDown then FState := bsExclusive;
        Repaint;
      end;
    if DoClick then Click;
    UpdateTracking;
  end;
end;

procedure THSImageButton.Notification(AComponent: TComponent;
  Operation: TOperation);
begin
  inherited Notification(AComponent, Operation);
  if Operation = opRemove then
  begin
    if AComponent = FImages then
    begin
      FImages := nil;
    end;
  end;
end;

procedure THSImageButton.ActionChange(Sender: TObject; CheckDefaults: Boolean);
begin
  inherited ActionChange(Sender, CheckDefaults);
  if Sender is TCustomAction then
    with TCustomAction(Sender) do
    begin
      if not CheckDefaults or (Self.ImageIndex = -1) then
        Self.ImageIndex := ImageIndex;
    end;
end;

procedure THSImageButton.Click;
begin
  inherited Click;
end;

function THSImageButton.GetActionLinkClass: TControlActionLinkClass;
begin
  Result := THSImageButtonActionLink;
end;

procedure THSImageButton.GlyphChanged(Sender: TObject);
begin
  Invalidate;
end;

procedure THSImageButton.ImageListChange(Sender: TObject);
begin
  Invalidate;
end;

procedure THSImageButton.ImageMarginsChange(Sender: TObject);
begin
  Invalidate;
end;

procedure THSImageButton.UpdateExclusive;
var
  Msg: TMessage;
begin
  if (FGroupIndex <> 0) and (Parent <> nil) then
  begin
    Msg.Msg := CM_BUTTONPRESSED;
    Msg.WParam := FGroupIndex;
    Msg.LParam := LPARAM(Self);
    Msg.Result := 0;
    Parent.Broadcast(Msg);
  end;
end;

procedure THSImageButton.SetDisabledImageIndex(const Value: TImageIndex);
begin
  FDisabledImageIndex := Value;
  Invalidate;
end;

procedure THSImageButton.SetDown(Value: Boolean);
begin
  if FGroupIndex = 0 then Value := False;
  if Value <> FDown then
  begin
    if FDown and (not FAllowAllUp) then Exit;
    FDown := Value;
    if Value then
    begin
      if FState = bsUp then Invalidate;
      FState := bsExclusive
    end
    else
    begin
      FState := bsUp;
      Repaint;
    end;
    if Value then UpdateExclusive;
  end;
end;

procedure THSImageButton.SetFlat(Value: Boolean);
begin
  if Value <> FFlat then
  begin
    FFlat := Value;
    Invalidate;
  end;
end;

procedure THSImageButton.SetGroupIndex(Value: Integer);
begin
  if FGroupIndex <> Value then
  begin
    FGroupIndex := Value;
    UpdateExclusive;
  end;
end;

procedure THSImageButton.SetHotImageIndex(const Value: TImageIndex);
begin
  FHotImageIndex := Value;
  Invalidate;
end;

procedure THSImageButton.SetImageAlignment(const Value: TImageAlignment);
begin
  FImageAlignment := Value;
  Invalidate;
end;

procedure THSImageButton.SetImageIndex(const Value: TImageIndex);
begin
  FImageIndex := Value;
  Invalidate;
end;

procedure THSImageButton.SetImageMargins(const Value: TImageMargins);
begin
  FImageMargins := Value;
  Invalidate;
end;

procedure THSImageButton.SetImages(const Value: TCustomImageList);
begin
  if Value <> FImages then
  begin
    if Images <> nil then
      Images.UnRegisterChanges(FImageChangeLink);
    FImages := Value;
    if Images <> nil then
    begin
      Images.RegisterChanges(FImageChangeLink);
      Images.FreeNotification(Self);
    end;
    Invalidate;
  end;
end;

procedure THSImageButton.SetMargin(Value: Integer);
begin
  if (Value <> FMargin) and (Value >= -1) then
  begin
    FMargin := Value;
    Invalidate;
  end;
end;

procedure THSImageButton.SetPressedImageIndex(const Value: TImageIndex);
begin
  FPressedImageIndex := Value;
  Invalidate;
end;

procedure THSImageButton.SetSpacing(Value: Integer);
begin
  if Value <> FSpacing then
  begin
    FSpacing := Value;
    Invalidate;
  end;
end;

procedure THSImageButton.SetTransparent(Value: Boolean);
begin
  if Value <> FTransparent then
  begin
    FTransparent := Value;
    if Value then
      ControlStyle := ControlStyle - [csOpaque] else
      ControlStyle := ControlStyle + [csOpaque];
    Invalidate;
  end;
end;

procedure THSImageButton.SetAllowAllUp(Value: Boolean);
begin
  if FAllowAllUp <> Value then
  begin
    FAllowAllUp := Value;
    UpdateExclusive;
  end;
end;

procedure THSImageButton.WMLButtonDblClk(var Message: TWMLButtonDblClk);
begin
  inherited;
  if FDown then DblClick;
end;

procedure THSImageButton.CMButtonPressed(var Message: TMessage);
var
  Sender: THSImageButton;
begin
  if Message.WParam = WPARAM(FGroupIndex) then
  begin
    Sender := THSImageButton(Message.LParam);
    if Sender <> Self then
    begin
      if Sender.Down and FDown then
      begin
        FDown := False;
        FState := bsUp;
        if (Action is TCustomAction) then
          TCustomAction(Action).Checked := False;
        Invalidate;
      end;
      FAllowAllUp := Sender.AllowAllUp;
    end;
  end;
end;

procedure THSImageButton.CMDialogChar(var Message: TCMDialogChar);
begin
  with Message do
    if IsAccel(CharCode, Caption) and Enabled and Visible and
      (Parent <> nil) and Parent.Showing then
    begin
      Click;
      Result := 1;
    end else
      inherited;
end;

procedure THSImageButton.CMEnabledChanged(var Message: TMessage);
const
  NewState: array[Boolean] of TButtonState = (bsDisabled, bsUp);
begin
  UpdateTracking;
  Repaint;
end;

procedure THSImageButton.CMFontChanged(var Message: TMessage);
begin
  Invalidate;
end;

procedure THSImageButton.CMMouseEnter(var Message: TMessage);
var
  NeedRepaint: Boolean;
begin
  inherited;
  { Don't draw a border if DragMode <> dmAutomatic since this button is meant to
    be used as a dock client. }
  NeedRepaint := FFlat and not FMouseInControl and Enabled and (DragMode <> dmAutomatic) and (GetCapture = 0);

  { Windows XP introduced hot states also for non-flat buttons. }
  if (NeedRepaint or StyleServices.Enabled) and not (csDesigning in ComponentState) then
  begin
    FMouseInControl := True;
    if Enabled then
      Repaint;
  end;
end;

procedure THSImageButton.CMMouseLeave(var Message: TMessage);
var
  NeedRepaint: Boolean;
begin
  inherited;
  NeedRepaint := FFlat and FMouseInControl and Enabled and not FDragging;
  { Windows XP introduced hot states also for non-flat buttons. }
  if NeedRepaint or StyleServices.Enabled then
  begin
    FMouseInControl := False;
    if Enabled then
      Repaint;
  end;
end;

procedure THSImageButton.CMTextChanged(var Message: TMessage);
begin
  Invalidate;
end;

{ THSImageButtonActionLink }

procedure THSImageButtonActionLink.AssignClient(AClient: TObject);
begin
  inherited AssignClient(AClient);
  FClient := AClient as THSImageButton;
end;

constructor THSImageButtonActionLink.Create(AClient: TObject);
begin
  inherited Create(AClient);
end;

function THSImageButtonActionLink.IsCheckedLinked: Boolean;
begin
  Result := inherited IsCheckedLinked and (FClient.GroupIndex <> 0) and
    FClient.AllowAllUp and (FClient.Down = TCustomAction(Action).Checked);
end;

function THSImageButtonActionLink.IsGroupIndexLinked: Boolean;
begin
  Result := inherited IsGroupIndexLinked and (FClient is THSImageButton) and
    (FClient.GroupIndex = TCustomAction(Action).GroupIndex);
end;

function THSImageButtonActionLink.IsImageIndexLinked: Boolean;
begin
  Result := inherited IsImageIndexLinked and
    (FClient.ImageIndex = TCustomAction(Action).ImageIndex);
end;

procedure THSImageButtonActionLink.SetChecked(Value: Boolean);
begin
  if IsCheckedLinked then THSImageButton(FClient).Down := Value;
end;

procedure THSImageButtonActionLink.SetGroupIndex(Value: Integer);
begin
  if IsGroupIndexLinked then THSImageButton(FClient).GroupIndex := Value;
end;

procedure THSImageButtonActionLink.SetImageIndex(Value: Integer);
begin
  if IsImageIndexLinked then THSImageButton(FClient).ImageIndex := Value;
end;

end.