delphi - 如何抑制 Delphi 中的标准 RadioButton 检查行为？

Question

我意识到这个有点奇怪，所以我会解释一下。对于一个简单的网络广播播放器，我需要一个控件来指定评级(1-5“星”)。我没有图形设计的经验或天赋，所以我绘制位图的所有尝试看起来都很荒谬/可怕，请选择。我找不到具有该功能且外观适合标准 VCL 控件的第 3 方控件。所以...

我突然想到，通过使用不带字幕的标准单选按钮，我可以实现与 Windows UI 的良好外观和一致性，如下所示:



我对 GroupIndex 属性有一个模糊(且不正确)的记忆；为每个单选按钮分配不同的值将允许同时检查多个单选按钮。唉，TRAdioButton 没有 GroupIndex 属性，就是这样。

有没有可能完全覆盖自然单选按钮行为 ，这样多个按钮可以同时显示为已选中？或者，

我可以获取 Windows 用于单选按钮的所有位图 (我假设它们是位图)从系统中直接绘制，包括主题支持？在这种情况下，我仍然希望保留单选按钮的所有效果，包括鼠标悬停“发光”等，这意味着获取所有“ native ”位图并根据需要绘制它们，可能在 TPaintBox 上。

Answer 1

为了最大的方便，你可以编写一个小控件来绘制原生的、主题的、单选框:

unit StarRatingControl;

interface

uses
  SysUtils, Windows, Messages, Graphics, Classes, Controls, UxTheme;

type
  TStarRatingControl = class(TCustomControl)
  private const
    DEFAULT_SPACING = 4;
    DEFAULT_NUM_STARS = 5;
    FALLBACK_BUTTON_SIZE: TSize = (cx: 16; cy: 16);
  private
    { Private declarations }
    FRating: integer;
    FBuffer: TBitmap;
    FSpacing: integer;
    FNumStars: integer;
    FButtonStates: array of integer;
    FButtonPos: array of TRect;
    FButtonSize: TSize;
    FDown: boolean;
    PrevButtonIndex: integer;
    PrevState: integer;
    FOnChange: TNotifyEvent;
    procedure SetRating(const Rating: integer);
    procedure SetSpacing(const Spacing: integer);
    procedure SetNumStars(const NumStars: integer);
    procedure SwapBuffers;
    procedure SetState(const ButtonIndex: integer; const State: integer);
  protected
    { Protected declarations }
    procedure WndProc(var Message: TMessage); override;
    procedure Paint; override;
    procedure MouseMove(Shift: TShiftState; X: Integer; Y: Integer); 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;
    destructor Destroy; override;
    { Public declarations }
  published
    { Published declarations }
    property OnChange: TNotifyEvent read FOnChange write FOnChange;
    property Rating: integer read FRating write SetRating default 3;
    property Spacing: integer read FSpacing write SetSpacing default DEFAULT_SPACING;
    property NumStars: integer read FNumStars write SetNumStars default DEFAULT_NUM_STARS;
    property OnDblClick;
    property OnKeyUp;
    property OnKeyPress;
    property OnKeyDown;
    property OnMouseWheelDown;
    property OnMouseWheelUp;
    property OnMouseWheel;
    property OnMouseEnter;
    property OnMouseLeave;
    property OnMouseActivate;
    property OnMouseMove;
    property OnMouseUp;
    property OnMouseDown;
    property OnClick;
    property Align;
    property Anchors;
    property Color;
  end;

procedure Register;

implementation

uses Math;

function IsIntInInterval(x, xmin, xmax: integer): boolean; inline;
begin
  IsIntInInterval := (xmin <= x) and (x <= xmax);
end;

function PointInRect(const X, Y: integer; const Rect: TRect): boolean; inline;
begin
  PointInRect := IsIntInInterval(X, Rect.Left, Rect.Right) and
                 IsIntInInterval(Y, Rect.Top, Rect.Bottom);
end;

procedure Register;
begin
  RegisterComponents('Rejbrand 2009', [TStarRatingControl]);
end;

{ TStarRatingControl }

constructor TStarRatingControl.Create(AOwner: TComponent);
var
  i: Integer;
begin
  inherited;
  FBuffer := TBitmap.Create;
  FRating := 3;
  FSpacing := DEFAULT_SPACING;
  FNumStars := DEFAULT_NUM_STARS;
  SetLength(FButtonStates, FNumStars);
  SetLength(FButtonPos, FNumStars);
  for i := 0 to high(FButtonStates) do
    FButtonStates[i] := RBS_NORMAL;
  FDown := false;
  PrevButtonIndex := -1;
  PrevState := -1;
end;

destructor TStarRatingControl.Destroy;
begin
  FBuffer.Free;
  inherited;
end;

procedure TStarRatingControl.MouseDown(Button: TMouseButton; Shift: TShiftState;
  X, Y: Integer);
var
  i: integer;
begin
  inherited;
  FDown := true;
  for i := 0 to FNumStars - 1 do
    if PointInRect(X, Y, FButtonPos[i]) then
    begin
      SetState(i, RBS_PUSHED);
      Exit;
    end;
end;

procedure TStarRatingControl.MouseMove(Shift: TShiftState; X, Y: Integer);
var
  i: Integer;
begin
  inherited;
  if FDown then Exit;
  for i := 0 to FNumStars - 1 do
    if PointInRect(X, Y, FButtonPos[i]) then
    begin
      SetState(i, RBS_HOT);
      Exit;
    end;
  SetState(-1, -1);
end;

procedure TStarRatingControl.MouseUp(Button: TMouseButton; Shift: TShiftState;
  X, Y: Integer);
var
  i: Integer;
begin
  inherited;
  for i := 0 to FNumStars - 1 do
    if PointInRect(X, Y, FButtonPos[i]) and (i = PrevButtonIndex) and (FRating <> i + 1) then
    begin
      SetRating(i + 1);
      if Assigned(FOnChange) then
        FOnChange(Self);
    end;
  FDown := false;
  MouseMove(Shift, X, Y);
end;

procedure TStarRatingControl.Paint;
var
  t: HTHEME;
  i: Integer;
begin
  inherited;
  FBuffer.Canvas.Brush.Color := Color;
  FBuffer.Canvas.FillRect(ClientRect);
  FButtonSize := FALLBACK_BUTTON_SIZE;

  if UseThemes then
  begin

    t := OpenThemeData(Handle, 'BUTTON');
    if t <> 0 then
      try

        GetThemePartSize(t, FBuffer.Canvas.Handle, BP_RADIOBUTTON, RBS_NORMAL, nil, TS_DRAW, FButtonSize);

        for i := 0 to FNumStars - 1 do
          with FButtonPos[i] do
          begin
            Left := i * (Spacing + FButtonSize.cx);
            Top := (Self.Height - FButtonSize.cy) div 2;
            Right := Left + FButtonSize.cx;
            Bottom := Top + FButtonSize.cy;
          end;

        for i := 0 to FNumStars - 1 do
          DrawThemeBackground(t,
                              FBuffer.Canvas.Handle,
                              BP_RADIOBUTTON,
                              IfThen(FRating > i, RBS_CHECKEDNORMAL) + FButtonStates[i],
                              FButtonPos[i],
                              nil);

      finally
        CloseThemeData(t);
      end;

  end
  else
  begin

    for i := 0 to FNumStars - 1 do
      with FButtonPos[i] do
      begin
        Left := i * (Spacing + FButtonSize.cx);
        Top := (Self.Height - FButtonSize.cy) div 2;
        Right := Left + FButtonSize.cx;
        Bottom := Top + FButtonSize.cy;
      end;

    for i := 0 to FNumStars - 1 do
      DrawFrameControl(FBuffer.Canvas.Handle,
                       FButtonPos[i],
                       DFC_BUTTON,
                       DFCS_BUTTONRADIO or IfThen(FRating > i, DFCS_CHECKED));

  end;

  SwapBuffers;

end;

procedure TStarRatingControl.SetNumStars(const NumStars: integer);
var
  i: integer;
begin
  if FNumStars <> NumStars then
  begin
    FNumStars := NumStars;
    SetLength(FButtonStates, FNumStars);
    SetLength(FButtonPos, FNumStars);
    for i := 0 to high(FButtonStates) do
      FButtonStates[i] := RBS_NORMAL;
    Paint;
  end;
end;

procedure TStarRatingControl.SetRating(const Rating: integer);
begin
  if FRating <> Rating then
  begin
    FRating := Rating;
    Paint;
  end;
end;

procedure TStarRatingControl.SetSpacing(const Spacing: integer);
begin
  if FSpacing <> Spacing then
  begin
    FSpacing := Spacing;
    Paint;
  end;
end;

procedure TStarRatingControl.SetState(const ButtonIndex, State: integer);
var
  i: Integer;
begin
  for i := 0 to FNumStars - 1 do
    if i = ButtonIndex then
      FButtonStates[i] := State
    else
      FButtonStates[i] := RBS_NORMAL;

  if (PrevButtonIndex <> ButtonIndex) or (PrevState <> State) then
    Paint;

  PrevButtonIndex := ButtonIndex;
  PrevState := State;

end;

procedure TStarRatingControl.SwapBuffers;
begin
  BitBlt(Canvas.Handle,
         0,
         0,
         Width,
         Height,
         FBuffer.Canvas.Handle,
         0,
         0,
         SRCCOPY);
end;

procedure TStarRatingControl.WndProc(var Message: TMessage);
begin
  inherited;
  case Message.Msg of
    WM_SIZE:
      begin
        FBuffer.SetSize(Width, Height);
        Paint;
      end;
  end;
end;

end.

只需调整属性 NumStars , Rating , 和 Spacing ， 玩得开心!



当然，您也可以编写一个使用自定义位图而不是 native Windows 单选按钮的组件。