paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-05-30 12:22:56 +02:00
Code Issues Packages Projects Releases Wiki Activity

added TCheckGroup

Browse Source 
git-svn-id: trunk@2285 -
This commit is contained in:
mattias 2002-08-17 23:41:13 +00:00
parent 9ab2b575b5
commit 4830cd8dca
4 changed files with 277 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
.gitattributes vendored
View File

@ -274,6 +274,7 @@ images/components/tcalendar.ico -text svneol=unset#image/x-icon
images/components/tcalendar.xpm -text svneol=native#image/x-xpixmap
images/components/tcheckbox.ico -text svneol=unset#image/x-icon
images/components/tcheckbox.xpm -text svneol=native#image/x-xpixmap
images/components/tcheckgroup.xpm -text svneol=native#image/x-xpixmap
images/components/tcolordialog.ico -text svneol=unset#image/x-icon
images/components/tcolordialog.xpm -text svneol=native#image/x-xpixmap
images/components/tcombobox.ico -text svneol=unset#image/x-icon
@ -468,6 +469,7 @@ lcl/include/controlsproc.inc svneol=native#text/pascal
lcl/include/customaction.inc svneol=native#text/pascal
lcl/include/customactionlist.inc svneol=native#text/pascal
lcl/include/customcheckbox.inc svneol=native#text/pascal
lcl/include/customcheckgroup.inc svneol=native#text/pascal
lcl/include/customcombobox.inc svneol=native#text/pascal
lcl/include/customcontrol.inc svneol=native#text/pascal
lcl/include/customedit.inc svneol=native#text/pascal

29
images/components/tcheckgroup.xpm Normal file
View File

@ -0,0 +1,29 @@
/* XPM */
static char * tcheckgroup_xpm[] = {
"20 19 7 1",
" c None",
". c #D30013",
"+ c #808080",
"@ c #C0C0C0",
"# c #FFFFFF",
"$ c #000000",
"% c #870013",
" ........ ",
"++@........@+++++++ ",
"+#@........@######@#",
"+#@@@@@@@@@@@@@@@@+#",
"+#@@@@@@@@@@@@@@@@+#",
"+#@@@@$@@@@@@@@@@@+#",
"+#@$@$@%%%%%%%%%@@+#",
"+#@@$@@@@@@@@@@@@@+#",
"+#@@@@@@@@@@@@@@@@+#",
"+#@@@@$@@@@@@@@@@@+#",
"+#@$@$@%%%%%%%%@@@+#",
"+#@@$@@@@@@@@@@@@@+#",
"+#@@@@@@@@@@@@@@@@+#",
"+#@@@@$@@@@@@@@@@@+#",
"+#@$@$@%%%%%%%%%@@+#",
"+#@@$@@@@@@@@@@@@@+#",
"+#@@@@@@@@@@@@@@@@+#",
"+@+++++++++++++++++#",
" ###################"};

4
lcl/controls.pp
View File

@ -602,6 +602,7 @@ type
procedure CMVisibleChanged(var Message : TLMessage); message CM_VISIBLECHANGED;
procedure ConstrainedResize(var MinWidth, MinHeight, MaxWidth, MaxHeight : TConstraintSize); virtual;
function GetPalette: HPalette; virtual;
procedure DoOnResize; virtual;
procedure Resize; virtual;
procedure RequestAlign; dynamic;
procedure BeginAutoDrag; dynamic;
@ -1446,6 +1447,9 @@ end.
{ =============================================================================
$Log$
Revision 1.109 2003/03/17 23:39:30 mattias
added TCheckGroup
Revision 1.108 2003/03/17 08:51:09 mattias
added IsWindowVisible

242
lcl/include/customcheckgroup.inc Normal file
View File

@ -0,0 +1,242 @@
// included by extctrls.pp
{******************************************************************************
TCustomCheckbox
******************************************************************************
*****************************************************************************
* *
* This file is part of the Lazarus Component Library (LCL) *
* *
* See the file COPYING.LCL, included in this distribution, *
* for details about the copyright. *
* *
* This program is distributed in the hope that it will be useful, *
* but WITHOUT ANY WARRANTY; without even the implied warranty of *
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *
* *
*****************************************************************************
}
{ TCustomCheckGroup }
procedure TCustomCheckGroup.ItemsChanged(Sender: TObject);
begin
UpdateItems;
if HandleAllocated then RecreateWnd;
OwnerFormDesignerModified(Self);
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 Assigned(OnItemClick) then OnItemClick(Self,Index);
end;
procedure TCustomCheckGroup.UpdateItems;
var
i : integer;
CheckBox: TCheckBox;
begin
// destroy checkboxes, if there are too many
while FButtonList.Count>FItems.Count do begin
TCheckBox(FButtonList[FButtonList.Count-1]).Free;
FButtonList.Delete(FButtonList.Count-1);
end;
// create as many TCheckBox as needed
while (FButtonList.Count<FItems.Count) do begin
CheckBox := TCheckBox.Create (self);
with CheckBox do begin
Name:='CheckBox'+IntToStr(FButtonList.Count);
AutoSize := False;
Parent := Self;
OnClick :=@Clicked;
end;
FButtonList.Add(CheckBox);
end;
for i:=0 to FItems.Count-1 do begin
CheckBox:=TCheckBox(FButtonList[i]);
CheckBox.Caption:=FItems[i];
end;
DoPositionButtons;
end;
function TCustomCheckGroup.GetChecked(Index: integer): boolean;
begin
if (Index < -1) or (Index >= FItems.Count) then
raise Exception.CreateFmt(rsIndexOutOfRange,[ClassName,Index,FItems.Count]);
Result:=TCheckBox(FButtonList[Index]).Checked;
end;
procedure TCustomCheckGroup.DoPositionButtons;
var
i : integer;
CheckBox: TCheckBox;
nextTop : integer;
nextLeft: integer;
vertDist: integer;
horzDist: integer;
rbWidth : integer;
CurRows: Integer;
begin
if (FItems<>nil) and (FItems.Count>0)
and (not (csLoading in ComponentState)) then begin
// position in rows and columns
CurRows := Rows;
vertDist := ClientHeight DIV CurRows;
horzDist := (ClientWidth-8) DIV FColumns;
nextLeft := 4;
nextTop := 0;
rbWidth := horzDist;
i := 0;
while i < FItems.Count do begin
CheckBox := TCheckBox(FButtonList[i]);
CheckBox.SetBounds(nextLeft,nextTop,rbWidth,vertDist);
inc (i);
if (i mod CurRows) = 0 then begin
inc(nextLeft, horzDist);
nextTop := 0;
end else begin
inc(nextTop, vertDist);
end;
end;
end;
end;
procedure TCustomCheckGroup.SetChecked(Index: integer; const AValue: boolean);
begin
if (Index < -1) or (Index >= FItems.Count) then
raise Exception.CreateFmt(rsIndexOutOfRange,[ClassName,Index,FItems.Count]);
TCheckBox(FButtonList[Index]).Checked:=AValue;
end;
procedure TCustomCheckGroup.SetItems(Value: TStrings);
begin
if (Value <> FItems) then
begin
FItems.Assign(Value);
UpdateItems;
if HandleAllocated then RecreateWnd;
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;
DoPositionButtons;
if HandleAllocated then RecreateWnd;
end;
end;
procedure TCustomCheckGroup.WMSize(var Message: TLMSize);
begin
DoPositionButtons;
inherited;
end;
procedure TCustomCheckGroup.DefineProperties(Filer: TFiler);
begin
inherited DefineProperties(Filer);
Filer.DefineBinaryProperty('Data', @ReadData, @WriteData,true);
end;
procedure TCustomCheckGroup.ReadData(Stream: TStream);
var
ChecksCount: integer;
Checks: string;
i: Integer;
begin
Stream.ReadBuffer(ChecksCount, SizeOf(Integer));
if ChecksCount>0 then begin
SetLength(Checks,ChecksCount);
Stream.ReadBuffer(Checks[1], ChecksCount);
for i:=0 to ChecksCount-1 do
Checked[i]:=(Checks[i+1]='1');
end;
end;
procedure TCustomCheckGroup.WriteData(Stream: TStream);
var
ChecksCount: integer;
Checks: string;
i: Integer;
begin
ChecksCount:=FItems.Count;
Stream.WriteBuffer(ChecksCount, SizeOf(Integer));
if ChecksCount>0 then begin
SetLength(Checks,ChecksCount);
for i:=0 to ChecksCount-1 do
if Checked[i] then
Checks[i+1]:='1'
else
Checks[i+1]:='0';
Stream.WriteBuffer(Checks[1], ChecksCount);
end;
end;
procedure TCustomCheckGroup.Loaded;
begin
inherited Loaded;
UpdateItems;
end;
procedure TCustomCheckGroup.DoOnResize;
begin
DoPositionButtons;
inherited DoOnResize;
end;
constructor TCustomCheckGroup.Create(TheOwner: TComponent);
begin
inherited Create(TheOwner);
FCreatingWnd := false;
ControlStyle := ControlStyle + [csCaptureMouse, csClickEvents, csSetCaption,
csDoubleClicks];
FItems := TStringList.Create;
TStringList(FItems).OnChanging := @ItemsChanged;
TStringList(FItems).OnChange := @ItemsChanged;
FButtonList := TList.Create;
FColumns := 1;
Width:= 250;
Height := 200;
end;
destructor TCustomCheckGroup.Destroy;
begin
FreeAndNil(FItems);
FreeAndNil(FButtonList);
inherited Destroy;
end;
function TCustomCheckGroup.Rows: integer;
begin
if FItems.Count>0 then
Result:=((FItems.Count-1) div Columns)+1
else
Result:=0;
end;
// included by extctrls.pp
{
$Log$
Revision 1.1 2003/03/17 23:39:30 mattias
added TCheckGroup
}