VB icon

MultiRadio Component

Email
Submitted on: 6/23/2016 3:59:54 PM
By: Craig Hagstrom 
Level: Advanced
User Rating: Unrated
Compatibility: Delphi 5, Delphi 4, Pre Delphi 4
Views: 1708
 
     A component that behaves as a classic radiobutton group or (when the Checkable property is true) as a combined radiobutton and checkbox group. Each item has a radiobutton and (when Checkable) checkbox associated. Clicking the radio button sets the whole component to radiobutton mode (one and only one choice) and clears all other choices. Clicking a checkbox sets the whole component to checkbox mode and preserves any current radiobutton choice. Individual items may disallow the checkbox function by entering the caption with a leading underscore. The component allows multiple columns, may be 3d or flat, and allows user-controlled colors.
 
code:
Can't Copy and Paste this?
Click here for a copy-and-paste friendly version of this code!
				
!**************************************
! Name: MultiRadio Component
! Description:A component that behaves as a classic radiobutton group or (when the Checkable property is true) as a combined radiobutton and checkbox group. Each item has a radiobutton and (when Checkable) checkbox associated. Clicking the radio button sets the whole component to radiobutton mode (one and only one choice) and clears all other choices. Clicking a checkbox sets the whole component to checkbox mode and preserves any current radiobutton choice. Individual items may disallow the checkbox function by entering the caption with a leading underscore. The component allows multiple columns, may be 3d or flat, and allows user-controlled colors.
! By: Craig Hagstrom
!**************************************

{ This unit defines a radio group that can operate in two modes. In the
 classic mode, the user gets one and only one choice. In MultiRadio
 mode the user can choose any number of items. When MultiRadio mode is
 enabled (the Checkable property), a parallel bank of checkboxes is
 visible beside the radio buttons.
 A CheckRadio item can either allow the checkbox use or not. Not
 allowing the checkbox makes it function like a normal radio button.
 You might do that just for consistency - so all the items in a group
 are the same type, though some don't allow both buttons. The checkbox
 is turned on and off by the caption -- a leading underscore prevents
 the checkbox function.
 The user changes modes by clicking in the appropriate bank of items.
 The component migrates checked/unchecked statuses as appropriate as
 the component shifts from radio to check. If the user clicks an
 item label the component treats it as a click in the currently-active
 side. If the current side is checkboxes and the label is not a
 checkable item, the component switches to the radio side;
 The CheckRadioGroup item-index reflects user choices. The group
 can have nothing checked (-1), can have a single item checked (0..n-1),
 or can have more than one item checked (-2). In that event, the
 program has to query all items in the list to see who is selected,
 using the GetItemState(n): TcheckBoxState. The user can turn on
 multiple individual items with SetItemState(n, state), or single
 items by setting the ItemIndex: -1 clears all, -2 does nothing,
 0-n turns on individual radiobuttons and sets the group to the
 Radio side.
 The CheckRadioGroup highlights the current (radio/check) side by
 drawing a bevel around the active side's elements. One or more
 TCheckRadioBevels are owned by the group, one per column. Bevels
 can have a custom color. The entire group can be 3d or flat.
 If the group is Checkable it has the two groups of buttons and shows
 the bevels. If not Checkable it has only radio buttons. Any
 method that would set the side to Check (i.e., SetSide(crsCheck))
 also turns on Checkable if not already on.
 Craig Hagstrom wrote it and owns it. Anyone can freely use it as long
 as they preserve this attribution. }
unit Mrad;
{ {$S-,W-,R-}
{ {$C PRELOAD}
interface
uses WinTypes, WinProcs, Messages, SysUtils, classes, Controls, Forms, Menus,
 Graphics, StdCtrls, Extctrls;
type
 TCheckRadioGroup = class;
 TCheckRadioSide = (crsRadio, crsCheck);
 TCheckRadioState = (cbUnchecked, cbChecked);
 TCheckRadioSource = (srcRadio, srcCheck, srcLabel);
 TThingCheckBox = class(TButtonControl)
 private
itemIndex: integer;
FState: TCheckRadioState; { covers just this button }
destructor Destroy; override;
procedure WMSetFocus(var Message: TWMSetFocus); message WM_SETFOCUS;
 protected
procedure SetState(Value: TCheckRadioState);
procedure CreateParams(var Params: TCreateParams); override;
procedure CreateWnd; override;
 public
constructor Create(RadioGroup: TCheckRadioGroup; whatIndex: integer);
procedure CMCtl3DChanged(var Message: TMessage);
message CM_CTL3DCHANGED;
procedure MouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
 published
property Color;
property Enabled;
property State: TCheckRadioState read FState write SetState;
property Visible;
property OnMouseDown;
 end;
 TThingRadioButton = class(TButtonControl)
 private
itemIndex: integer;
FState: TCheckRadioState; { covers just this button }
destructor Destroy; override;
procedure WMSetFocus(var Message: TWMSetFocus); message WM_SETFOCUS;
 protected
procedure SetState(Value: TCheckRadioState);
procedure CreateParams(var Params: TCreateParams); override;
procedure CreateWnd; override;
 public
constructor Create(RadioGroup: TCheckRadioGroup; whatIndex: integer);
procedure CMCtl3DChanged(var Message: TMessage);
 message CM_CTL3DCHANGED;
procedure MouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
 published
property State: TCheckRadioState read FState write SetState;
property Color;
property Enabled;
property Visible;
property OnMouseDown;
 end;
{ The label "owns" the state for the 3-object group, and tells the
 radioButton and checkBox when to turn themselves on or off. }
 TThingLabel = class(TLabel)
 private
itemIndex: integer;
FTag: integer;
FState: TcheckRadioState; { covers the entire item }
boolCheckable: boolean;{ absent leading underscore }
FCtrlCaption: string; { what was passed, not displayed }
destructor Destroy; override;
 protected
procedure SetState(Value: TCheckRadioState);
 public
constructor Create(RadioGroup: TCheckRadioGroup; whatIndex: integer);
procedure MouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure SetCaption(value: string);
 published
property Checkable: boolean read boolCheckable;
property Tag: integer read FTag write FTag;
property CtrlCaption: string read FCtrlCaption write SetCaption;
property State: TCheckRadioState read FState write SetState;
property Visible;
property OnMouseDown;
 end;
 TCheckRadioBevel = class(TPanel)
 private
destructor Destroy; override;
 public
constructor Create(RadioGroup: TCheckRadioGroup);
 end;
 TCheckRadioGroup = class(TCustomControl)
 private
FCheckBoxes: TList;
FRadioButtons: TList;
FThingLabels: TList;
FGangBevels: TList; { one per column }
FItems: TStrings;
FCheckable: boolean;
FSide: TCheckRadioSide;
FColorSide: TColor;
FColorSideParent: boolean;
FItemIndex: Integer;
FColumns: Integer;
FReading: Boolean;
FUpdating: Boolean;
procedure CMDialogChar(var Message: TCMDialogChar);
 message CM_DIALOGCHAR;
procedure CMTextChanged(var Message: TMessage);
 message CM_TEXTCHANGED;
procedure CMCtl3DChanged(var Message: TMessage);
 message CM_CTL3DCHANGED;
procedure ArrangeButtons;
function GetItemIndex: integer;
procedure ItemsChange(Sender: TObject);
procedure SetRadioButtonCount(Value: Integer);
procedure SetCheckable(value: boolean);
procedure SetCheckBoxCount(Value: Integer);
procedure SetColorSide(Value: TColor);
procedure SetColorSideParent(Value: boolean);
procedure ForceItemState(itemIndex: integer; Value: TCheckRadioState);
procedure SetThingLabelCount(Value: Integer);
procedure SetBevelCount(Value: Integer);
procedure SetColumns(Value: Integer);
procedure SetItemIndex(Value: Integer);
procedure SetItems(Value: TStrings);
procedure SetSide(Value: TCheckRadioSide);
procedure TurnSiblingsOff(whatsOn: integer);
procedure UpdateButtons;
procedure CMEnabledChanged(var Message: TMessage); message CM_ENABLEDCHANGED;
procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED;
procedure WMSize(var Message: TWMSize); message WM_SIZE;
 protected
procedure AlignControls(AControl: TControl; var Rect: TRect); override;
procedure ReadState(Reader: TReader); override;
function CanModify: Boolean; virtual;
procedure Paint; override;
 public
procedure HandleClick(Source: TCheckRadioSide; whatIndex: integer;
Shift: TShiftState);
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
function GetItemState(itemIndex: integer): TCheckRadioState;
function SetItemState(itemIndex: integer;
 value: TCheckRadioState): boolean;
 published
property Align;
property Caption;
property Checkable: boolean read FCheckable write SetCheckable
 default true;
property Color;
property ColorSide: TColor read FColorSide write SetColorSide;
property ColorSideParent: boolean read FColorSideParent
write SetColorSideParent default true;
property Columns: Integer read FColumns write SetColumns default 1;
property Ctl3D;
property DragCursor;
property DragMode;
property Enabled;
property Font;
property ItemIndex: Integer read GetItemIndex
 write SetItemIndex default -1;
property Items: TStrings read FItems write SetItems;
property ParentColor;
property ParentCtl3D;
property ParentFont;
property ParentShowHint;
property PopupMenu;
property ShowHint;
property Side: TCheckRadioSide
read FSide write SetSide default crsRadio;
property TabOrder;
property TabStop;
property Visible;
property OnClick;
property OnDragDrop;
property OnDragOver;
property OnEndDrag;
property OnEnter;
property OnExit;
 end;
procedure Register;
implementation
uses Consts;
procedure Register;
begin
 RegisterComponents('Samples', [TCheckRadioGroup]);
end;
type
 TSelection = record
StartPos, EndPos: Integer;
 end;
const
 BorderStyles: array[TBorderStyle] of Longint = (0, WS_BORDER);
 DIMCHECKRADIO: byte = 13;
{ TThingCheckBox }
constructor TThingCheckBox.Create(RadioGroup: TCheckRadioGroup;
 whatIndex: integer);
begin
 inherited Create(RadioGroup);
 parent := RadioGroup;
 RadioGroup.FCheckBoxes.Add(Self);
 itemIndex := whatIndex;
 Width := 17;
 Height := 17;
 Ctl3d := true;
 FState := cbUnchecked;
 OnMouseDown := MouseDown;
end;
destructor TThingCheckBox.Destroy;
begin
 TCheckRadioGroup(Owner).FCheckBoxes.Remove(Self);
 inherited Destroy;
end;
{ Send an eligible click up to the parent so it handles both items.
 The parent will decide whether to honor it and what state to set
 this item to. }
procedure TThingCheckBox.MouseDown(Sender: TObject; Button: TMouseButton;
 Shift: TShiftState; X, Y: Integer);
begin
 (Parent as TCheckRadioGroup).HandleClick(crsCheck, itemIndex, Shift);
end;
procedure TThingCheckBox.SetState(Value: TCheckRadioState);
begin
 if FState <> Value then
begin
 FState := Value;
 if HandleAllocated then
SendMessage(Handle, BM_SETCHECK, Cardinal(FState), 0);
end;
end;
procedure TThingCheckBox.CreateParams(var Params: TCreateParams);
const
 Alignments: array[TLeftRight] of LongInt = (BS_LEFTTEXT, 0);
begin
 inherited CreateParams(Params);
 CreateSubClass(Params, 'BUTTON');
 with Params do
Style := Style or BS_3STATE;
end;
procedure TThingCheckBox.CreateWnd;
begin
 inherited CreateWnd;
 SendMessage(Handle, BM_SETCHECK, Cardinal(FState), 0);
 if Ctl3D and (Ctl3DBtnWndProc <> nil) then
DefWndProc := Ctl3DBtnWndProc;
end;
procedure TThingCheckBox.CMCtl3DChanged(var Message: TMessage);
begin
 RecreateWnd;
end;
procedure TThingCheckBox.WMSetFocus(var Message: TWMSetFocus);
begin
 if Ctl3D and (Ctl3DBtnWndProc <> nil) then UpdateWindow(Handle);
 inherited;
end;
{ TThingRadioButton }
constructor TThingRadioButton.Create(RadioGroup: TCheckRadioGroup;
 whatIndex: integer);
begin
 inherited Create(RadioGroup);
 parent := RadioGroup;
 RadioGroup.FRadioButtons.add(Self);
 itemIndex := whatIndex;
 Width := 17;
 Height := 17;
 Ctl3d := true;
 FState := cbUnchecked;
 OnMouseDown := MouseDown;
end;
destructor TThingRadioButton.Destroy;
begin
 TCheckRadioGroup(Owner).FRadioButtons.Remove(Self);
 inherited Destroy;
end;
{ Send an eligible click up to the parent so it handles both items.
 The parent will decide whether to honor it and what state to set
 this item to. }
procedure TThingRadioButton.MouseDown(Sender: TObject;
Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
 (Parent as TCheckRadioGroup).HandleClick(crsRadio, itemIndex, Shift);
end;
procedure TThingRadioButton.SetState(Value: TCheckRadioState);
begin
 if FState <> Value then
begin
 FState := Value;
 if HandleAllocated then
SendMessage(Handle, BM_SETCHECK, Cardinal(FState), 0);
end;
end;
procedure TThingRadioButton.CreateParams(var Params: TCreateParams);
const
 Alignments: array[TLeftRight] of LongInt = (BS_LEFTTEXT, 0);
begin
 inherited CreateParams(Params);
 CreateSubClass(Params, 'BUTTON');
 with Params do
Style := Style or BS_RADIOBUTTON;
end;
procedure TThingRadioButton.CreateWnd;
begin
 inherited CreateWnd;
 SendMessage(Handle, BM_SETCHECK, Cardinal(FState), 0);
 if Ctl3D and (Ctl3DBtnWndProc <> nil) then
DefWndProc := Ctl3DBtnWndProc;
end;
procedure TThingRadioButton.CMCtl3DChanged(var Message: TMessage);
begin
 RecreateWnd;
end;
procedure TThingRadioButton.WMSetFocus(var Message: TWMSetFocus);
begin
 if Ctl3D and (Ctl3DBtnWndProc <> nil) then UpdateWindow(Handle);
 inherited;
end;
{ TThingLabel }
constructor TThingLabel.Create(RadioGroup: TCheckRadioGroup;
whatIndex: integer);
begin
 inherited Create(RadioGroup);
 parent := RadioGroup;
 RadioGroup.FThingLabels.Add(Self);
 itemIndex := whatIndex;
 autoSize := true;
 Width := 120;
 Height := 17;
 boolCheckable := true;
 OnMouseDown := MouseDown;
end;
destructor TThingLabel.Destroy;
begin
 TCheckRadioGroup(Owner).FThingLabels.Remove(Self);
 inherited Destroy;
end;
procedure TThingLabel.MouseDown(Sender: TObject; Button: TMouseButton;
 Shift: TShiftState; X, Y: Integer);
var newState: TCheckRadioState;
newSide: TCheckRadioSide;
begin
 newSide := (parent as TCheckRadioGroup).Side;
 if (newSide = crsCheck) then
if (boolCheckable = false) then
 newSide := crsRadio;
 (Parent as TCheckRadioGroup).HandleClick(newSide, itemIndex, Shift);
end;
procedure TThingLabel.SetCaption(value: string);
begin
 if (FCtrlCaption <> Value) then
begin
 FCtrlCaption := value;
 if (copy (FCtrlCaption, 1, 1) = '_') then
 begin
if (length(FCtrlCaption) > 1) then
 Caption :=
 copy(FCtrlCaption, 2, length(FCtrlCaption) -1);
boolCheckable := false
 end
else
 begin
Caption := FCtrlCaption;
boolCheckable := true
 end;
 Width := canvas.textWidth(caption);
end;
end;
procedure TThingLabel.SetState(Value: TCheckRadioState);
begin
 if FState <> Value then
FState := Value;
end;
{ TCheckRadioBevel }
constructor TCheckRadioBevel.Create(RadioGroup: TCheckRadioGroup);
begin
 inherited Create(RadioGroup);
 parent := RadioGroup;
 RadioGroup.FGangBevels.Add(Self);
 bevelOuter := bvLowered;
 bevelInner := bvNone;
 bevelWidth := 2;
end;
destructor TCheckRadioBevel.Destroy;
begin
 TCheckRadioGroup(Owner).FGangBevels.Remove(Self);
 inherited Destroy;
end;
{ TCheckRadioGroup }
constructor TCheckRadioGroup.Create(AOwner: TComponent);
begin
 inherited Create(AOwner);
 ControlStyle := [csAcceptsControls, csCaptureMouse, csClickEvents,
csSetCaption, csDoubleClicks];
 FCheckBoxes := TList.Create;
 FRadioButtons := TList.Create;
 FGangBevels := TList.Create;
 FThingLabels := TList.Create;
 FItems := TStringList.Create;
 TStringList(FItems).OnChange := ItemsChange;
 FItemIndex := -1;
 FColumns := 1;
 FCheckable := true;
 FColorSideParent := true;
 Width := 185;
 Height := 105;
end;
destructor TCheckRadioGroup.Destroy;
begin
 SetRadioButtonCount(0);
 SetCheckBoxCount(0);
 SetThingLabelCount(0);
 SetBevelCount(0);
 TStringList(FItems).OnChange := nil;
 FItems.Free;
 FRadioButtons.Free;
 FCheckBoxes.Free;
 FThingLabels.Free;
 FGangBevels.Free;
 inherited Destroy;
end;
procedure TCheckRadioGroup.AlignControls(AControl: TControl;
 var Rect: TRect);
begin
 Canvas.Font := Font;
 Inc(Rect.Top, Canvas.TextHeight('0'));
 InflateRect(Rect, -1, -1);
 if Ctl3d then InflateRect(Rect, -1, -1);
 inherited AlignControls(AControl, Rect);
end;
procedure TCheckRadioGroup.ArrangeButtons;
var
 ButtonsPerCol, ButtonWidth, ButtonHeight, TopMargin, I: Integer;
 ButtonInterMargin, ColumnInterMargin: integer;
 BevelHeight, BevelTop, BevelBaseLeft: integer;
 LabelLeftFudge: integer;
 DC: HDC;
 SaveFont: HFont;
 Metrics: TTextMetric;
 am3d: boolean;
begin
 if (FRadioButtons.Count <> 0) and not FReading then
 begin
DC := GetDC(0);
SaveFont := SelectObject(DC, Font.Handle);
GetTextMetrics(DC, Metrics);
SelectObject(DC, SaveFont);
ReleaseDC(0, DC);
if (FColorSideParent) then
 ColorSide := Color;
ButtonsPerCol := (FRadioButtons.Count + FColumns - 1) div FColumns;
ButtonWidth := ((Width - 10) div FColumns) - 5;
ColumnInterMargin := 5;
I := Height - Metrics.tmHeight - 5;
ButtonHeight := I div ButtonsPerCol;
if (ButtonHeight > DIMCHECKRADIO) then
ButtonInterMargin := (ButtonHeight - DIMCHECKRADIO) div 2
 else
ButtonInterMargin := 0;
TopMargin := Metrics.tmHeight + 1 + (I mod ButtonsPerCol) div 2;
if (FCheckable) then
begin
 am3d := ctl3D;
 LabelLeftFudge := 42;
 BevelTop := 17;
 BevelHeight := Height - BevelTop - 4;;
 SetBevelCount(FColumns);
 if (FSide = crsRadio) then
 BevelBaseLeft := 5 + ColumnInterMargin
else
 BevelBaseLeft := 23 + ColumnInterMargin;
 for I := 0 to FColumns -1 do
with TCheckRadioBevel(FGangBevels[I]) do
 begin
if am3d then
BevelOuter := bvLowered
 else
BevelOuter := bvNone;
parentColor := FColorSideParent;
Color := FColorSide;
SetBounds((I * ButtonWidth) + BevelBaseLeft,
BevelTop, 18, BevelHeight);
SendToBack
 end;
end
 else
begin
 LabelLeftFudge := 24;
 SetBevelCount(0)
end;
for I := 0 to FRadioButtons.Count - 1 do
 begin
with TThingRadioButton(FRadioButtons[I]) do
 begin
ParentColor := true;
Ctl3D := am3d;
SetBounds((I div ButtonsPerCol) * ButtonWidth + 8 +
 ColumnInterMargin,
 (I mod ButtonsPerCol) * ButtonHeight + TopMargin +
 ButtonInterMargin, DIMCHECKRADIO, DIMCHECKRADIO);
Visible := True;
 end;
with TThingCheckBox(FCheckBoxes[I]) do
 begin
if (FCheckable = true) then
begin
 if (TThingLabel(FThingLabels[I]).Checkable) then
 begin
Ctl3D := am3d;
SetBounds((I div ButtonsPerCol) * ButtonWidth +
 25 + ColumnInterMargin,
(I mod ButtonsPerCol) * ButtonHeight +
 TopMargin + ButtonInterMargin,
DIMCHECKRADIO, DIMCHECKRADIO);
Visible := True
 end
else
 SetBounds(0, 0, 0, 0)
end
 else
SetBounds(0, 0, 0, 0)
 end;
with TThingLabel(FThingLabels[I]) do
 begin
SetBounds((I div ButtonsPerCol) * ButtonWidth +
ColumnInterMargin + LabelLeftFudge,
 (I mod ButtonsPerCol) * ButtonHeight + TopMargin - 2 +
 ButtonInterMargin, ButtonWidth -42, Metrics.tmHeight);
Visible := True;
 end;
 end;
 end;
end;
{ set the label and the active-side button. If checks are active
 and this has no checkbox allowed, ignore the request. }
procedure TCheckRadioGroup.ForceItemState(itemIndex: integer;
value: TCheckRadioState);
begin
 if (itemIndex > -1) then
if (itemIndex < FItems.Count -1) then
 begin
TThingLabel(FThingLabels[itemIndex]).State := value;
if (Side = crsRadio) then
TThingRadioButton(FRadioButtons[itemIndex]).State := value
 else
if (TThingLabel(FThingLabels[itemIndex]).Checkable = true) then
 TThingCheckBox(FCheckBoxes[itemIndex]).State := value
 end;
end;
function TCheckRadioGroup.GetItemIndex: integer;
var iLoop: integer;
iCounted: integer;
iFirstHit: integer;
begin
 iCounted := 0;
 iFirstHit := -1;
 for iLoop := 0 to FItems.Count - 1 do
begin
 if (TThingLabel(FThingLabels[iLoop]).State = cbChecked) then
begin
 iCounted := iCounted + 1;
 if iFirstHit < 0 then
iFirstHit := iLoop
end
end;
 case iCounted of
0 : result := -1;
1 : result := iFirstHit;
 else
result := -2;
 end;
end;
function TCheckRadioGroup.GetItemState(itemIndex: integer):
TCheckRadioState;
begin
 result := cbUnchecked;
 if itemIndex > -1 then
if itemIndex < FItems.Count then
 result := TThingLabel(FThingLabels[itemIndex]).State;
end;
{ A click sets the whole group to the side the click came from.
 A label knows whether it can handle checks, and will set its click
 to radio before passing it up, if needed. }
procedure TCheckRadioGroup.HandleClick(Source: TCheckRadioSide;
 whatIndex: integer; Shift: TShiftState);
var allOk: boolean;
newState: TCheckRadioState;
newSide: TCheckRadioSide;
oldSide: TcheckRadioSide;
begin
 inherited SetFocus;
 oldSide := FSide;
 newSide := Source;
 { A shift- or ctl-click is some windows person trying to multiselect,
so switch (if needed) to the checkside and take it. }
 if (newSide = crsRadio) then
if (oldSide = crsRadio) then
 if (ssCtrl in Shift) then
 newSide := crsCheck
else
 if (ssShift in Shift) then
newSide := crsCheck;
 if (FSide <> newSide) then
if (newSide = crsCheck) then
Side := crsCheck{ setSide routine moves buttonstates }
 else
Side := crsRadio;
 { The group is all set. Now handle the guy who actually clicked. }
 if TThingLabel(FThingLabels[whatIndex]).State = cbChecked then
 { if moving to the other side, keep this check active }
 begin
if (oldSide = FSide) then
begin
 TThingLabel(FThingLabels[whatIndex]).State := cbUnchecked;
 TThingRadioButton(FRadioButtons[whatIndex]).State :=
cbUnchecked;
 TThingCheckBox(FCheckBoxes[whatIndex]).State := cbUnchecked
end
 else
begin
 if (FSide = crsRadio) then
 begin
TThingRadioButton(FRadioButtons[whatIndex]).State :=
 cbChecked;
TThingCheckBox(FCheckBoxes[whatIndex]).State :=
 cbUnchecked
 end
else
 begin
TThingRadioButton(FRadioButtons[whatIndex]).State :=
 cbUnchecked;
TThingCheckBox(FCheckBoxes[whatIndex]).State :=
 cbChecked
 end
end
 end
else
 begin
TThingLabel(FThingLabels[whatIndex]).State := cbChecked;
if FSide = crsRadio then
 begin
TThingRadioButton(FRadioButtons[whatIndex]).State :=
cbChecked;
TurnSiblingsOff(whatIndex)
 end
else
 TThingCheckBox(FCheckBoxes[whatIndex]).State := cbChecked
 end;
 inherited Click;
end;
procedure TCheckRadioGroup.ItemsChange(Sender: TObject);
var
 Form: TForm;
begin
 if not FReading then
 begin
if FItemIndex >= FItems.Count then FItemIndex := FItems.Count - 1;
UpdateButtons;
 end;
end;
procedure TCheckRadioGroup.Paint;
var
 H: Integer;
 R: TRect;
 C: array [Byte] of Char;
 CLen: Integer;
begin
 with Canvas do
 begin
Font := Self.Font;
H := TextHeight('0');
R := Rect(0, H div 2 - 1, Width, Height);
if Ctl3D then
begin
 Inc(R.Left);
 Inc(R.Top);
 Brush.Color := clBtnHighlight;
 FrameRect(R);
 OffsetRect(R, -1, -1);
 Brush.Color := clBtnShadow;
end else
 Brush.Color := clWindowFrame;
FrameRect(R);
StrPCopy(C, Text);
if C[0] <> #0 then
begin
 StrPCopy(C, Text);
 CLen := StrLen(C);
 R := Rect(8, 0, 0, H);
 DrawText(Handle, C, CLen, R, DT_LEFT or DT_SINGLELINE or DT_CALCRECT);
 Brush.Color := Color;
 DrawText(Handle, C, CLen, R, DT_LEFT or DT_SINGLELINE);
end;
 end;
end;
procedure TCheckRadioGroup.ReadState(Reader: TReader);
begin
 FReading := True;
 inherited ReadState(Reader);
 FReading := False;
 UpdateButtons;
end;
procedure TCheckRadioGroup.SetBevelCount(Value: Integer);
begin
 while FGangBevels.Count < Value do TCheckRadioBevel.Create(Self);
 while FGangBevels.Count > Value do
TCheckRadioBevel(FGangBevels.Last).Free;
end;
procedure TCheckRadioGroup.SetCheckable(value: boolean);
begin
 if (value <> FCheckable) then
begin
 FCheckable := value;
 if (FSide = crsCheck) then
if (FCheckable = false) then
 Side := crsRadio;
 ArrangeButtons
end;
end;
procedure TCheckRadioGroup.SetCheckBoxCount(Value: Integer);
begin
 while FCheckBoxes.Count < Value do
TThingCheckBox.Create(Self, FCheckBoxes.Count);
 while FCheckBoxes.Count > Value do
TThingCheckBox(FCheckBoxes.Last).Free;
end;
procedure TCheckRadioGroup.SetColorSide(Value: TColor);
begin
 if (FColorSide <> Value) then
begin
 FColorSide := value;
 ColorSideParent := false;
 ArrangeButtons
end;
end;
procedure TCheckRadioGroup.SetColorSideParent(Value: boolean);
begin
 if (FColorSideParent <> Value) then
begin
 FColorSideParent := value;
 if FColorSideParent then
ArrangeButtons
end;
end;
procedure TCheckRadioGroup.SetColumns(Value: Integer);
begin
 if Value < 1 then Value := 1;
 if Value > 16 then Value := 16;
 if FColumns <> Value then
 begin
FColumns := Value;
ArrangeButtons;
 end;
end;
{ this forces the group to the radio side if necessary }
procedure TCheckRadioGroup.SetItemIndex(Value: Integer);
var iLoop: integer;
begin
 if FReading then FItemIndex := Value else
 begin
if (Value < -1) then Value := -1;
if (Value >= FItems.Count) then
 Value := FItems.Count - 1;
if (ItemIndex <> Value) then
 if (FItems.Count > 0) then
begin
 TurnSiblingsOff(-1);
 FItemIndex := value;
 if (value < 0) then exit;
 TThingLabel(FThingLabels[FItemIndex]).State := cbChecked;
 if (FSide = crsRadio) then
 TThingRadioButton(FRadioButtons[FItemIndex]).State :=
cbChecked
else
 if (TThingLabel(FThingLabels[FItemIndex]).Checkable) then
 TThingCheckBox(FCheckBoxes[FItemIndex]).State :=
cbChecked
else
 begin
Side := crsRadio;
TThingRadioButton(FRadioButtons[FItemIndex]).State :=
cbChecked
 end;
end;
 end;
end;
procedure TCheckRadioGroup.SetItems(Value: TStrings);
begin
 FItems.Assign(Value);
 UpdateButtons;
end;
{ Set an item per a user call. If the user is going to the trouble
 of setting individual items, we assume they can verify that the
 item is checkable (since the user gave the strings) and that the
 group is on the right side. If this call sets a radiobutton, the
 others are turned off. If this call is on the check side and the
 item is not checkable, the result is false. An item out of range
 also returns False. }
function TCheckRadioGroup.SetItemState(itemIndex: integer;
 value: TCheckRadioState): boolean;
var iLoop: integer;
begin
 result := true;
 if (itemIndex < 0) then
 result := false
else
 if (itemIndex > FItems.count -1) then
result := false;
 if (result = true) then
begin
 if (FSide = crsRadio) then
 begin
if (value = cbChecked) then
 TurnSiblingsOff(-1);
TThingLabel(FThingLabels[itemIndex]).State := value;
TThingRadioButton(FRadioButtons[itemIndex]).State := value
 end
else
 if (TThingLabel(FThingLabels[itemIndex]).Checkable) then
 begin
TThingCheckBox(FCheckBoxes[itemIndex]).State := value;
TThingLabel(FThingLabels[itemIndex]).State := value;
 end
else
 result := false
end;
end;
procedure TCheckRadioGroup.SetRadioButtonCount(Value: Integer);
begin
 while FRadioButtons.Count < Value do
TThingRadioButton.Create(Self, FRadioButtons.Count);
 while FRadioButtons.Count > Value do
TThingRadioButton(FRadioButtons.Last).Free;
end;
procedure TCheckRadioGroup.SetSide(Value: TCheckRadioSide);
var iLoop: integer;
foundRadio: boolean;
begin
 foundRadio := false;
 if FSide <> Value then begin
FSide := Value;
if (Value = crsRadio) then
 begin
for iLoop := 0 to FItems.Count - 1 do begin
 TThingCheckBox(FCheckBoxes[iLoop]).State := cbUnchecked;
 if (TThingLabel(FThingLabels[iLoop]).State = cbChecked) then
if (foundRadio = false) then
begin
 foundRadio := true;
 TThingRadioButton(FRadioButtons[iLoop]).State := cbChecked
end
 else
TThingLabel(FThingLabels[iLoop]).State := cbUnchecked;
end;
 end
else
 begin
if not FCheckable then
 Checkable := true;
for iLoop := 0 to FItems.Count - 1 do
 begin
TThingRadioButton(FRadioButtons[iLoop]).State := cbUnchecked;
if (TThingLabel(FThingLabels[iLoop]).State = cbChecked) then
 if (TThingLabel(FThingLabels[iLoop]).Checkable) then
 TThingCheckBox(FCheckBoxes[iLoop]).State := cbChecked
else
 TThingLabel(FThingLabels[iLoop]).State := cbUnchecked;
 end
 end;
ArrangeButtons;
 end;
end;
procedure TCheckRadioGroup.SetThingLabelCount(Value: Integer);
begin
 while FThingLabels.Count < Value do
TThingLabel.Create(Self, FThingLabels.Count);
 while FThingLabels.Count > Value do
TThingLabel(FThingLabels.Last).Free;
end;
procedure TCheckRadioGroup.TurnSiblingsOff(whatsOn: integer);
var iLoop: integer;
begin
 for iLoop := 0 to FItems.Count - 1 do
if iLoop <> whatsOn then
 begin
TThingRadioButton(FRadioButtons[iLoop]).State := cbUnchecked;
TThingCheckBox(FCheckBoxes[iLoop]).State := cbUnchecked;
TThingLabel(FThingLabels[iLoop]).State := cbUnchecked
 end;
end;
procedure TCheckRadioGroup.UpdateButtons;
var
 I: Integer;
begin
 SetRadioButtonCount(FItems.Count);
 SetCheckBoxCount(FItems.Count);
 SetThingLabelCount(FItems.Count);
 for I := 0 to FRadioButtons.Count - 1 do
TThingLabel(FThingLabels[I]).CtrlCaption := FItems[I];
 ArrangeButtons;
end;
procedure TCheckRadioGroup.CMDialogChar(var Message: TCMDialogChar);
begin
 with Message do
if IsAccel(CharCode, Caption) and CanFocus then
begin
 SelectFirst;
 Result := 1;
end else
 inherited;
end;
procedure TCheckRadioGroup.CMTextChanged(var Message: TMessage);
begin
 Invalidate;
 Realign;
end;
procedure TCheckRadioGroup.CMCtl3DChanged(var Message: TMessage);
begin
 inherited;
 ArrangeButtons;
 Invalidate;
 Realign;
end;
procedure TCheckRadioGroup.CMEnabledChanged(var Message: TMessage);
var
 I: Integer;
begin
 inherited;
 for I := 0 to FRadioButtons.Count - 1 do
TThingRadioButton(FRadioButtons[I]).Enabled := Enabled;
end;
procedure TCheckRadioGroup.CMFontChanged(var Message: TMessage);
begin
 inherited;
 ArrangeButtons;
end;
procedure TCheckRadioGroup.WMSize(var Message: TWMSize);
begin
 inherited;
 ArrangeButtons;
end;
function TCheckRadioGroup.CanModify: Boolean;
begin
 Result := True;
end;
end.


Report Bad Submission
Use this form to tell us if this entry should be deleted (i.e contains no code, is a virus, etc.).
This submission should be removed because:

Your Vote

What do you think of this code (in the Advanced category)?
(The code with your highest vote will win this month's coding contest!)
Excellent  Good  Average  Below Average  Poor (See voting log ...)
 

Other User Comments


 There are no comments on this submission.
 

Add Your Feedback
Your feedback will be posted below and an email sent to the author. Please remember that the author was kind enough to share this with you, so any criticisms must be stated politely, or they will be deleted. (For feedback not related to this particular code, please click here instead.)
 

To post feedback, first please login.