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

Question

我意识到这个有点奇怪,所以我会解释.对于一个简单的互联网广播播放器,我需要一个控件来指定评级(1-5"星").我没有图形设计的经验或才能,所以我绘制位图的所有尝试看起来都很荒谬/糟糕,请你选择.我找不到具有该功能的第三方控件,并且看起来符合标准VCL控件.所以...

在我看来,通过使用没有标题的标准radiobutton,我可以通过Windows UI获得良好的外观和一致性,如下所示:

我对GroupIndex属性进行了模糊(不正确)的回忆; 为每个单选按钮分配不同的值将允许同时检查多个单选按钮.唉,TRadioButton没有GroupIndex属性,所以就是这样.

1. 是否可以完全覆盖自然的无线电按钮行为,以便同时显示多个按钮？要么,

2. 我可以从系统中获取Windows用于radiobuttons的所有位图(我假设它们是位图)并直接绘制它们,包括主题支持吗？在这种情况下,我仍然希望保留radiobutton的所有效果,包括鼠标悬停"发光"等,这意味着获取所有"本机"位图并根据需要绘制它们,可能在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,玩得开心!

评级控制http://privat.rejbrand.se/ratingctrl.png

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