delphibuttontpanel

How best to create a TPanel with a close 'cross' button in the top right?


There are several third-pary controls (such as the Raize Components) which have a close 'cross' button 'option' (eg the page control). My requirement is simpler, I'd like to plonk a cross 'button' aligned top right on to a TPanel and access its clicked event. Is there either a simple way of doint this without creating a TPanel descendent, or is there a paid or free library component that I can use?


Solution

  • I wrote a control for you.

    unit CloseButton;
    
    interface
    
    uses
      Windows, Messages, SysUtils, Classes, Controls, UxTheme;
    
    type
      TCloseButton = class(TCustomControl)
      private
        FMouseInside: boolean;
        function MouseButtonDown: boolean;
      protected
        procedure Paint; override;
        procedure MouseMove(Shift: TShiftState; X: Integer; Y: Integer); override;
        procedure WndProc(var Message: TMessage); override;
        procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X: Integer;
          Y: Integer); override;
        procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X: Integer;
          Y: Integer); override;
      public
        constructor Create(AOwner: TComponent); override;
      published
        property Align;
        property Anchors;
        property Enabled;
        property OnClick;
        property OnMouseUp;
        property OnMouseDown;
      end;
    
    procedure Register;
    
    implementation
    
    procedure Register;
    begin
      RegisterComponents('Rejbrand 2009', [TCloseButton]);
    end;
    
    { TCloseButton }
    
    constructor TCloseButton.Create(AOwner: TComponent);
    begin
      inherited;
      Width := 32;
      Height := 32;
    end;
    
    function TCloseButton.MouseButtonDown: boolean;
    begin
      MouseButtonDown := GetKeyState(VK_LBUTTON) and $8000 <> 0;
    end;
    
    procedure TCloseButton.MouseDown(Button: TMouseButton; Shift: TShiftState; X,
      Y: Integer);
    begin
      inherited;
      Invalidate;
    end;
    
    procedure TCloseButton.MouseMove(Shift: TShiftState; X, Y: Integer);
    begin
      inherited;
      if not FMouseInside then
      begin
        FMouseInside := true;
        Invalidate;
      end;
    end;
    
    procedure TCloseButton.MouseUp(Button: TMouseButton; Shift: TShiftState; X,
      Y: Integer);
    begin
      inherited;
      Invalidate;
    end;
    
    procedure TCloseButton.Paint;
    
      function GetAeroState: cardinal;
      begin
        result := CBS_NORMAL;
        if not Enabled then
          result := CBS_DISABLED
        else
          if FMouseInside then
            if MouseButtonDown then
              result := CBS_PUSHED
            else
              result := CBS_HOT;
      end;
    
      function GetClassicState: cardinal;
      begin
        result := 0;
        if not Enabled then
          result := DFCS_INACTIVE
        else
          if FMouseInside then
            if MouseButtonDown then
              result := DFCS_PUSHED
            else
              result := DFCS_HOT;
      end;
    
    var
      h: HTHEME;
    begin
      inherited;
      if UseThemes then
      begin
        h := OpenThemeData(Handle, 'WINDOW');
        if h <> 0 then
          try
            DrawThemeBackground(h,
              Canvas.Handle,
              WP_CLOSEBUTTON,
              GetAeroState,
              ClientRect,
              nil);
          finally
            CloseThemeData(h);
          end;
      end
      else
        DrawFrameControl(Canvas.Handle,
          ClientRect,
          DFC_CAPTION,
          DFCS_CAPTIONCLOSE or GetClassicState)
    end;
    
    procedure TCloseButton.WndProc(var Message: TMessage);
    begin
      inherited;
      case Message.Msg of
        WM_MOUSELEAVE:
          begin
            FMouseInside := false;
            Invalidate;
          end;
        CM_ENABLEDCHANGED:
          Invalidate;
      end;
    end;
    
    end.
    

    Sample (with and without themes enabled):

    Screenshot Screenshot

    Just put this in a TPanel at the top-right corner and set Anchors to top and right.