How to simulate Word 2010-style Options category selector

Accepted answer +8 upvotes

You could use the TButtonGroup component.

Using VCL Styles is by far the easiest solution but as like you said, using styles in XE2 is quite uncomfortable, in my opinion this feature only really became viable in XE3.

Per your request to use the default painting methods I’m submitting my solution,

source code of the project available here.

This project requires an image, the image is zipped together with the project.

Compiled and tested in XE4.

type

  TButtonGroup = class(Vcl.ButtonGroup.TButtonGroup)
   protected
     procedure Paint; override;
  end;

  TForm1 = class(TForm)
    ButtonGroup1: TButtonGroup;
    Panel1: TPanel;
    procedure ButtonGroup1DrawButton(Sender: TObject; Index: Integer;
      Canvas: TCanvas; Rect: TRect; State: TButtonDrawState);
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;
  MBitmap : TBitmap;

implementation

{$R *.dfm}

procedure TButtonGroup.Paint;
var
  R : TRect;
begin
   inherited;
   R := GetClientRect;
   R.Top := Self.Items.Count * Self.ButtonHeight;
   {Remove the clBtnFace background default Painting}
   Self.Canvas.FillRect(R);
end;

procedure TForm1.ButtonGroup1DrawButton(Sender: TObject; Index: Integer;
  Canvas: TCanvas; Rect: TRect; State: TButtonDrawState);
var
  TextLeft, TextTop: Integer;
  RectHeight: Integer;
  ImgTop: Integer;
  Text : String;
  TextOffset: Integer;
  ButtonItem: TGrpButtonItem;
  InsertIndication: TRect;
  DrawSkipLine : TRect;
  TextRect: TRect;
  OrgRect: TRect;

begin

    //OrgRect := Rect;  //icon
    Canvas.Font := TButtonGroup(Sender).Font;

      if bdsSelected in State then begin
         Canvas.CopyRect(Rect,MBitmap.Canvas,
                         System.Classes.Rect(0, 0, MBitmap.Width, MBitmap.Height));
         Canvas.Brush.Color := RGB(255,228,138);
      end
      else if bdsHot in State then
      begin
        Canvas.Brush.Color := RGB(194,221,244);
        Canvas.Font.Color := clBlack;

      end
       else
        Canvas.Brush.color := clWhite;

      if not (bdsSelected in State)
      then
        Canvas.FillRect(Rect);


      InflateRect(Rect, -2, -1);


    { Compute the text location }
    TextLeft := Rect.Left + 4;
    RectHeight := Rect.Bottom - Rect.Top;
     TextTop := Rect.Top + (RectHeight - Canvas.TextHeight('Wg')) div 2; { Do not localize }
    if TextTop < Rect.Top then
      TextTop := Rect.Top;
    if bdsDown in State then
    begin
      Inc(TextTop);
      Inc(TextLeft);
    end;

    ButtonItem := TButtonGroup(Sender).Items.Items[Index];

    TextOffset := 0;

    { Draw the icon  - if you need to display icons}

//    if (FImages <> nil) and (ButtonItem.ImageIndex > -1) and
//        (ButtonItem.ImageIndex < FImages.Count) then
//    begin
//      ImgTop := Rect.Top + (RectHeight - FImages.Height) div 2;
//      if ImgTop < Rect.Top then
//        ImgTop := Rect.Top;
//      if bdsDown in State then
//        Inc(ImgTop);
//      FImages.Draw(Canvas, TextLeft - 1, ImgTop, ButtonItem.ImageIndex);
//      TextOffset := FImages.Width + 1;
//    end;


    { Show insert indications }

    if [bdsInsertLeft, bdsInsertTop, bdsInsertRight, bdsInsertBottom] * State <> [] then
    begin
      Canvas.Brush.Color := clSkyBlue;
      InsertIndication := Rect;
      if bdsInsertLeft in State then
      begin
        Dec(InsertIndication.Left, 2);
        InsertIndication.Right := InsertIndication.Left + 2;
      end
      else if bdsInsertTop in State then
      begin
        Dec(InsertIndication.Top);
        InsertIndication.Bottom := InsertIndication.Top + 2;
      end
      else if bdsInsertRight in State then
      begin
        Inc(InsertIndication.Right, 2);
        InsertIndication.Left := InsertIndication.Right - 2;
      end
      else if bdsInsertBottom in State then
      begin
        Inc(InsertIndication.Bottom);
        InsertIndication.Top := InsertIndication.Bottom - 2;
      end;
      Canvas.FillRect(InsertIndication);
      //Canvas.Brush.Color := FillColor;
    end;

    if gboShowCaptions in TButtonGroup(Sender).ButtonOptions then
    begin
      { Avoid clipping the image }
      Inc(TextLeft, TextOffset);
      TextRect.Left := TextLeft;
      TextRect.Right := Rect.Right - 1;
      TextRect.Top := TextTop;
      TextRect.Bottom := Rect.Bottom -1;
      Text := ButtonItem.Caption;
      Canvas.TextRect(TextRect, Text, [tfEndEllipsis]);
    end;

end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  MBitmap := TBitmap.Create;
  try
  MBitmap.LoadFromFile('bg.bmp');
  except
    on E : Exception do
      ShowMessage(E.ClassName+' error raised, with message : '+E.Message);
  end;

end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
  MBitmap.Free;
end;

DFM :

object Form1: TForm1
  Left = 0
  Top = 0
  Caption = 'Form1'
  ClientHeight = 398
  ClientWidth = 287
  Color = clBtnFace
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clWindowText
  Font.Height = -11
  Font.Name = 'Tahoma'
  Font.Style = []
  OldCreateOrder = False
  Position = poScreenCenter
  StyleElements = []
  OnCreate = FormCreate
  OnDestroy = FormDestroy
  PixelsPerInch = 96
  TextHeight = 13
  object Panel1: TPanel
    AlignWithMargins = True
    Left = 5
    Top = 5
    Width = 137
    Height = 388
    Margins.Left = 5
    Margins.Top = 5
    Margins.Right = 5
    Margins.Bottom = 5
    Align = alLeft
    BevelKind = bkFlat
    BevelOuter = bvNone
    Color = clWhite
    ParentBackground = False
    TabOrder = 0
    StyleElements = [seFont]
    object ButtonGroup1: TButtonGroup
      AlignWithMargins = True
      Left = 4
      Top = 4
      Width = 125
      Height = 378
      Margins.Left = 4
      Margins.Top = 4
      Margins.Right = 4
      Margins.Bottom = 2
      Align = alClient
      BevelInner = bvNone
      BevelOuter = bvNone
      BorderStyle = bsNone
      ButtonOptions = [gboFullSize, gboGroupStyle, gboShowCaptions]
      DoubleBuffered = True
      Font.Charset = DEFAULT_CHARSET
      Font.Color = clWindowText
      Font.Height = -11
      Font.Name = 'Segoe UI'
      Font.Style = []
      Items = <
        item
          Caption = 'General'
        end
        item
          Caption = 'Display'
        end
        item
          Caption = 'Proofing'
        end
        item
          Caption = 'Save'
        end
        item
          Caption = 'Language'
        end
        item
          Caption = 'Advanced'
        end>
      ParentDoubleBuffered = False
      TabOrder = 0
      OnDrawButton = ButtonGroup1DrawButton
    end
  end
end

There is a Panel container in there hosting the TButtonGroup, it is not needed, simply added for visual improvement.

If you want to change the color of the selection at runtime then I suggest using efg’s Hue/Saturation method to change the Hue of the image, that way the color panel remains but the color will change.

To gain support for VCL Styles simply detach the ButtonGroup1DrawButton Event from the TButtonGroup component, that way the default DrawButton Event can kick in which adds support for that.