uses Themes, CommCtrl;
const
UM_DESTROYCONTROL = WM_USER + 1;
type
TForm1 =
class(TForm)
private
procedure ShowTabCheckBoxes;
procedure ShowTabCheckBox(PageIndex: Integer);
function CheckBoxChecked(TabSheetIndex: Integer;
var CheckBoxStatus: Integer): Boolean;
procedure ReCalculateCheckBoxPositions;
procedure UmDestroyControl(
var msg: TMessage);
message UM_DESTROYCONTROL;
procedure CheckBoxDestroy(Sender: TObject);
public
{ Public-Deklarationen }
end;
TrwCheckBox =
class(TCheckBox)
private
{ Private-Deklarationen }
public
constructor Create(AOwner: TComponent);
override;
end;
constructor TrwCheckBox.Create(AOwner: TComponent);
begin
inherited;
Height := 14;
Width := 14;
// Checked := True;
// AllowGrayed := DoAllowGrayed;
end;
procedure TForm1.ReCalculateCheckBoxPositions;
var
i: Byte;
Rect: TRect;
begin
if PageControl1.PageCount <> 0
then
begin
for i := 0
to Pred(PageControl1.PageCount)
do
begin
Rect := PageControl1.TabRect(i);
with TrwCheckBox(PageControl1.Pages[i].Tag)
do
begin
Top := Rect.Top + 3;
Left := Rect.Left + 4;
end;
end;
RedrawWindow(PageControl1.Handle,
nil, 0,
RDW_ERASE
or RDW_FRAME
or RDW_INVALIDATE
or RDW_ALLCHILDREN);
end;
end;
procedure TForm1.ShowTabCheckBox(PageIndex: Integer);
var
sCheckBox: TrwCheckBox;
Rect: TRect;
begin
sCheckBox := TrwCheckBox.Create(PageControl1.Pages[PageIndex]);
sCheckBox.Parent := PageControl1;
sCheckBox.OnMouseUp := CheckBoxOnMouseUp;
PageControl1.Pages[PageIndex].Tag := Integer(sCheckBox);
//Notlösung, da kA wie man das TRect manuell setzt um den Reiter zu verbreitern:
PageControl1.Pages[PageIndex].Caption := '
' + PageControl1.Pages[PageIndex].Caption;
Rect := PageControl1.TabRect(PageIndex);
sCheckBox.Top := Rect.Top + 3;
sCheckBox.Left := Rect.Left + 4;
end;
procedure TForm1.ShowTabCheckBoxes;
var
i: Byte;
begin
for i := 0
to Pred(PageControl1.PageCount)
do
ShowTabCheckBox(i);
end;
{*** Diese Funktion ist nur für meine Zwecke nötig ***}
function TForm1.CheckBoxChecked(TabSheetIndex: Integer;
var CheckBoxStatus: Integer): Boolean;
begin
case TrwCheckBox(PageControl1.Pages[TabSheetIndex].Tag).State
of
cbUnchecked : CheckBoxStatus := 0;
cbGrayed : CheckBoxStatus := 1;
cbChecked : CheckBoxStatus := 2;
end;
result := CheckBoxStatus > 0;
end;
{*** Diese Funktion ist nur für meine Zwecke nötig ***}
{*** nur zum löschen eines Tabs wärend der Laufzeit notwendig ***}
procedure TForm1.UmDestroyControl(
var msg: TMessage);
begin
TComponent(msg.LParam).Owner.Free;
ReCalculateCheckBoxPositions;
end;
procedure TForm1.CheckBoxDestroy(Sender: TObject);
begin
if PtInRect((Sender
as TrwCheckBox).ClientRect, Point(X, Y))
then
PostMessage(
Handle, UM_DESTROYCONTROL, 0, Integer(Sender));
end;
{*** nur zum löschen eines Tabs wärend der Laufzeit notwendig ***}
procedure TForm1.FormCreate(Sender: TObject);
begin
ShowTabCheckBoxes;
end;