{%MainUnit ../extctrls.pp} {****************************************************************************** TCustomCheckbox ****************************************************************************** ***************************************************************************** This file is part of the Lazarus Component Library (LCL) See the file COPYING.modifiedLGPL.txt, included in this distribution, for details about the license. ***************************************************************************** } type { TCheckGroupStringList } TCheckGroupStringList = class(TStringList) private FCheckGroup: TCustomCheckGroup; protected procedure Changed; override; public constructor Create(TheCheckGroup: TCustomCheckGroup); end; { TCheckGroupStringList } procedure TCheckGroupStringList.Changed; begin inherited Changed; if (UpdateCount = 0) then FCheckGroup.UpdateAll else FCheckGroup.UpdateInternalObjectList; end; constructor TCheckGroupStringList.Create(TheCheckGroup: TCustomCheckGroup); begin inherited Create; FCheckGroup := TheCheckGroup; end; { TCustomCheckGroup } constructor TCustomCheckGroup.Create(TheOwner: TComponent); begin inherited Create(TheOwner); FCreatingWnd := false; ControlStyle := ControlStyle + [csCaptureMouse, csClickEvents, csSetCaption, csDoubleClicks]; FItems := TCheckGroupStringList.Create(Self); FButtonList := TList.Create; FColumnLayout := clHorizontalThenVertical; FColumns := 1; FAutoFill := true; ChildSizing.Layout:=cclLeftToRightThenTopToBottom; ChildSizing.ControlsPerLine:=FColumns; ChildSizing.ShrinkHorizontal:=crsScaleChilds; ChildSizing.ShrinkVertical:=crsScaleChilds; ChildSizing.EnlargeHorizontal:=crsHomogenousChildResize; ChildSizing.EnlargeVertical:=crsHomogenousChildResize; ChildSizing.LeftRightSpacing:=6; ChildSizing.TopBottomSpacing:=6; end; destructor TCustomCheckGroup.Destroy; begin FreeAndNil(FItems); FreeAndNil(FButtonList); inherited Destroy; end; procedure TCustomCheckGroup.ItemKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState); begin if Key <> 0 then KeyDown(Key, Shift); end; procedure TCustomCheckGroup.ItemKeyUp(Sender: TObject; var Key: Word; Shift: TShiftState); begin if Key <> 0 then KeyUp(Key, Shift); end; procedure TCustomCheckGroup.ItemKeyPress(Sender: TObject; var Key: Char); begin if Key <> #0 then KeyPress(Key); end; procedure TCustomCheckGroup.ItemUTF8KeyPress(Sender: TObject; var UTF8Key: TUTF8Char); begin UTF8KeyPress(UTF8Key); end; procedure TCustomCheckGroup.RaiseIndexOutOfBounds(Index: integer ) ; begin raise Exception.CreateFmt(rsIndexOutOfBounds, [ClassName, Index, FItems.Count - 1]); end; procedure TCustomCheckGroup.SetAutoFill(const AValue: boolean); begin if FAutoFill=AValue then exit; FAutoFill:=AValue; DisableAlign; try if FAutoFill then begin ChildSizing.EnlargeHorizontal:=crsHomogenousChildResize; ChildSizing.EnlargeVertical:=crsHomogenousChildResize; end else begin ChildSizing.EnlargeHorizontal:=crsAnchorAligning; ChildSizing.EnlargeVertical:=crsAnchorAligning; end; finally EnableAlign; end; end; procedure TCustomCheckGroup.Clicked(Sender: TObject); var Index: Integer; begin Index:=FButtonList.IndexOf(Sender); if Index<0 then exit; DoClick(Index); end; procedure TCustomCheckGroup.DoClick(Index: integer); begin if [csLoading,csDestroying,csDesigning]*ComponentState<>[] then exit; EditingDone; if Assigned(OnItemClick) then OnItemClick(Self,Index); end; procedure TCustomCheckGroup.UpdateItems; var i : integer; CheckBox: TCheckBox; begin if FUpdatingItems then exit; FUpdatingItems:=true; try // destroy checkboxes, if there are too many while FButtonList.Count>FItems.Count do begin TObject(FButtonList[FButtonList.Count-1]).Free; FButtonList.Delete(FButtonList.Count-1); end; // create as many TCheckBox as needed while (FButtonList.Count= FItems.Count) then RaiseIndexOutOfBounds(Index); Result:=TCheckBox(FButtonList[Index]).Enabled; end; procedure TCustomCheckGroup.SetCheckEnabled(Index: integer; const AValue: boolean); begin if (Index < -1) or (Index >= FItems.Count) then RaiseIndexOutOfBounds(Index); TCheckBox(FButtonList[Index]).Enabled:=AValue; end; procedure TCustomCheckGroup.SetColumnLayout(const AValue: TColumnLayout); begin if FColumnLayout=AValue then exit; FColumnLayout:=AValue; if FColumnLayout=clHorizontalThenVertical then ChildSizing.Layout:=cclLeftToRightThenTopToBottom else ChildSizing.Layout:=cclTopToBottomThenLeftToRight; UpdateControlsPerLine; end; function TCustomCheckGroup.GetChecked(Index: integer): boolean; begin if (Index < -1) or (Index >= FItems.Count) then RaiseIndexOutOfBounds(Index); Result:=TCheckBox(FButtonList[Index]).Checked; end; procedure TCustomCheckGroup.SetChecked(Index: integer; const AValue: boolean); begin if (Index < -1) or (Index >= FItems.Count) then RaiseIndexOutOfBounds(Index); // disable OnClick TCheckBox(FButtonList[Index]).OnClick:=nil; // set value TCheckBox(FButtonList[Index]).Checked:=AValue; // enable OnClick TCheckBox(FButtonList[Index]).OnClick:=@Clicked; end; procedure TCustomCheckGroup.SetItems(Value: TStrings); begin if (Value <> FItems) then begin FItems.Assign(Value); UpdateItems; UpdateControlsPerLine; end; end; procedure TCustomCheckGroup.SetColumns(Value: integer); begin if Value <> FColumns then begin if (Value < 1) then raise Exception.Create('TCustomCheckGroup: Columns must be >= 1'); FColumns := Value; UpdateControlsPerLine; end; end; procedure TCustomCheckGroup.DefineProperties(Filer: TFiler); begin inherited DefineProperties(Filer); Filer.DefineBinaryProperty('Data', @ReadData, @WriteData, FItems.Count > 0); end; procedure TCustomCheckGroup.ReadData(Stream: TStream); var ChecksCount: integer; Checks: string; i: Integer; v: Integer; begin ChecksCount:=ReadLRSInteger(Stream); if ChecksCount>0 then begin SetLength(Checks,ChecksCount); Stream.ReadBuffer(Checks[1], ChecksCount); for i:=0 to ChecksCount-1 do begin v:=ord(Checks[i+1]); Checked[i]:=((v and 1)>0); CheckEnabled[i]:=((v and 2)>0); end; end; end; procedure TCustomCheckGroup.WriteData(Stream: TStream); var ChecksCount: integer; Checks: string; i: Integer; v: Integer; begin ChecksCount:=FItems.Count; WriteLRSInteger(Stream,ChecksCount); if ChecksCount>0 then begin SetLength(Checks,ChecksCount); for i:=0 to ChecksCount-1 do begin v:=0; if Checked[i] then inc(v,1); if CheckEnabled[i] then inc(v,2); Checks[i+1]:=chr(v); end; Stream.WriteBuffer(Checks[1], ChecksCount); end; end; procedure TCustomCheckGroup.Loaded; begin inherited Loaded; UpdateItems; end; procedure TCustomCheckGroup.DoOnResize; begin inherited DoOnResize; end; function TCustomCheckGroup.Rows: integer; begin if FItems.Count>0 then Result:=((FItems.Count-1) div Columns)+1 else Result:=0; end; procedure TCustomCheckGroup.FlipChildren(AllLevels: Boolean); begin // no flipping end; // included by extctrls.pp