Question

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

我突然意识到，通过使用没有标题的标准无线电按钮，我可以在Windows用户界面上获得良好的外观和一致性，如下所示：

radiobuttons without captions as a basic rating control

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

是否可以完全覆盖自然单选按钮行为，以便多个按钮同时显示为已检查？或者，
我可以获取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，即可享受乐趣！

Rating Control http://privat.rejbrand.se/ratingctrl.png

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

Answer 2

制作看起来像单选按钮但行为不同的单选按钮会使用户感到困惑。此外，当您决定显示现有评级时，最终需要半校验标记。因此，像显示进度条（可能是自定义颜色或自定义绘制），“完全”用户满意度是一个更好的选择。

Answer 3

我同意尤金和克雷格的观点，就像明星会更好，但是，回答提出的问题：

通过拨打LoadBitmap with OBM_CHECKBOXES可获得未指定的单选按钮图像。您可以将其直接分配给TBitmap的Handle属性，然后将宽度除以4，将高度除以3以获得子位图测量值。使用TCanvas.BrushCopy进行绘图。

要绘制主题图像，您需要使用Delphi的Themes.pas。请使用ThemeServices.GetElementDetails或tbRadioButtonUncheckedNormal致电tbRadioButtonCheckedNormal，并将结果与客户端矩形一起传递给ThemeServices.DrawElement。

这是一个简单的覆盖，它将TCheckBox绘制为一个选中的单选按钮，以便您可以看到它是如何工作的：

TCheckBox = class(StdCtrls.TCheckBox)
  constructor Create(AOwner: TComponent); override;
  procedure PaintWindow(DC: HDC); override;
end;

constructor TCheckBox.Create(AOwner: TComponent);
begin
  inherited;
  ControlState := ControlState + [csCustomPaint];
end;

procedure TCheckBox.PaintWindow(DC: HDC);
begin
  ThemeServices.DrawElement(DC,
    ThemeServices.GetElementDetails(tbRadioButtonCheckedNormal), ClientRect);
end;

Answer 4

您可以将每个单选按钮放在单独的（微小）面板上，这样就可以替代缺少的GroupIndex属性。

在我看来，也许不是最好的方法，相对便宜。

Answer 5

很好的灵感给了Andreas Rejbrand（+1）。我将为您提供您可能正在寻找的some small piece of code。它的形式有两个重叠的图像，一个共同的事件 - OnMouseDown。它只包含一些疯狂的公式 - 不幸的是有一些常数，这是我前段时间做的。但对不起，我不是数学家，所以请耐心等待我，让我们也把它作为灵感：）

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

5 个答案: