如何模拟Word 2010样式的选项类别选择器

Question

Word 2010中的"选项"对话框通过一组白色"切换"按钮实现类别选择器,这些按钮在单击(选中)时变为橙色.

如何在Delphi中重新实现这种行为？需要符合当前的Windows主题(即必须可以将按钮颜色指定为clWindow,而不是clWhite).

编辑:澄清 - 我只有左侧的类别选择器有问题.其他一切都相当简单.

Answer 1

您可以使用 TButtonGroup组件.

使用VCL样式是迄今为止最简单的解决方案,但就像你说的那样,在XE2中使用样式非常不舒服,在我看来这个功能在XE3中才真正可行.

根据您的要求使用我提交解决方案的默认绘画方法,

这里有可用的项目源代码.

这个项目需要一个图像,图像与项目一起压缩.

在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

在托管TButtonGroup的地方有一个Panel容器,不需要它,只是添加了视觉改进.

如果你想在运行时更改选择的颜色,我建议使用efg的色相/饱和度方法来改变图像的色调,这样颜色面板保持不变,但颜色会改变.

要获得对VCL样式的支持,只需将ButtonGroup1DrawButton事件从TButtonGroup组件中分离出来,这样就可以启动默认的DrawButton事件,从而增加了对它的支持.

Answer 2

您可以使用样式设置为lbOwnerDrawFixed的TListBox(如果间距的大小不重要)或lbOwnerDrawVariable(如果是).

然后,您可以相应地处理OnDrawItem和OnMeasureItem.

使用clWindow将没有问题,但是AFAIK橙色不是Windows主题的一部分,但是您可以通过从clHighlight开始然后应用色调偏移,然后应用着色的亮度偏移来获得与主题匹配的内容.

如果你的色调偏移是恒定的,它会自动适应主题颜色.

示例代码(没有橙色的HueShift):删除TListBox,设置lbOwnerDrawFixed,将ItemHeight调整为28,将字体设置为"Segoe UI"并使用以下OnDrawItem

var
   canvas : TCanvas;
   txt : String;
begin
   canvas:=ListBox1.Canvas;
   canvas.Brush.Style:=bsSolid;
   canvas.Brush.Color:=clWindow;
   canvas.FillRect(Rect);
   InflateRect(Rect, -2, -2);
   if odSelected in State then begin
      canvas.Pen.Color:=RGB(194, 118, 43);
      canvas.Brush.Color:=RGB(255, 228, 138);
      canvas.RoundRect(Rect.Left, Rect.Top, Rect.Right, Rect.Bottom, 6, 6);
      canvas.Pen.Color:=RGB(246, 200, 103);
      canvas.RoundRect(Rect.Left+1, Rect.Top+1, Rect.Right-1, Rect.Bottom-1, 6, 6);
   end;
   canvas.Font.Color:=clWindowText;
   canvas.Brush.Style:=bsClear;
   txt:=ListBox1.Items[Index];
   Rect.Left:=Rect.Left+10;
   canvas.TextRect(Rect, txt, [tfLeft, tfSingleLine, tfVerticalCenter]);
end;

如果你将拥有多个这样的组件,那么当然最好只是将TListBox子类化,如果你想要RoundRect的抗锯齿,可以使用GR32或GDI +.

请注意,为了向后兼容XP,"Segoe UI"字体应该动态设置,因为它在XP中不可用(在XP中"Arial"是一个很好的后备,"Tahoma"看起来更近但不保证在那里)