How to suppress standard RadioButton check behavior in Delphi? - delphi

Question

I realize this one is a bit strange, so I'll explain. For a simple internet radio player I need a control to specify rating (1-5 "stars"). I have no experience or talent for graphical design, so all my attempts at drawing bitmaps look ridiculous/awful, take your pick. I couldn't find a 3rd party control with that functionality and look that fits standard VCL controls. So...
It occurred to me that I could achieve an OK look and consistency with Windows UI by using standard radiobuttons without captions, like this:
I had a vague (and incorrect) recollection of a GroupIndex property; assigning a different value to each radiobutton would let multiple radiobuttons be checked at the same time. Alas, TRadioButton does not have a GroupIndex property, so that's that.
Is it possible to completely override the natural radiobutton behavior, so that more than one button can show up as checked at the same time? Or,
Can I acquire all the bitmaps Windows uses for radiobuttons (I assume they're bitmaps) from the system and draw them directly, including theming support? In this case I would still like to retain all the effects of a radiobutton, including the mouse hover "glow", etc, so that means getting all the "native" bitmaps and drawing them as necessary, perhaps on a TPaintBox.

Answer 1

For maximum convenience, you could write a small control that draws native, themed, radio boxes:
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.
Just adjust the properties NumStars, Rating, and Spacing, and have fun!
Of course, you could also write a component that uses custom bitmaps instead of the native Windows radio buttons.

Answer 2

Making radio buttons that look like radio buttons but behave differently would confuse the user. Also, you would end up needing half-check marks when you decide to display existing ratings. So something like a progress bar (maybe custom-colored or custom-drawn) to display, how "complete" user satisfaction is could be a better option.

Answer 3

I agree with Eugene and Craig that something like stars would be better, but, to answer the question posed:
The unthemed radio button images are available by calling LoadBitmap with OBM_CHECKBOXES. You can assign that directly to a TBitmap's Handle property, and then divide the width by 4 and the height by 3 to get the subbitmap measurements. Use TCanvas.BrushCopy to do the drawing.
To draw the themed images you need to use Delphi's Themes.pas. Specifically call ThemeServices.GetElementDetails with tbRadioButtonUncheckedNormal or tbRadioButtonCheckedNormal and pass the result to ThemeServices.DrawElement along with the client rect.
Here's a simple override that makes a TCheckBox draw as a checked radio button so you can see how it works:
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

You could place each radiobutton on a separate (tiny) panel, and that would make a substitute for the missing GroupIndex property.
Maybe not the nicest method, still relatively cheap, it seems to me.

Answer 5

Good inspiration gave you Andreas Rejbrand (+1). I'll provide you just some small piece of code of what you are probably looking for. It's form with two overlapped images with one common event - OnMouseDown. It contains just some mad formula - unfortunately with constants, which I've made some time ago. But sorry I'm not mathematician, so please be patient with me and let's take this also as the inspiration :)