ID объекта в TabControl

[alexkam]

Добавляем ID. Допустим ID=1.
TabControl.Tabs.AddObject(Description, TObject(ID));
Получаем ID.
Result :=longint(TabControl.Tabs.Objects[TabControl.TabIndex]);
Почему Result не равен 1?

[Maxizar]

alexkam - а Вы скорее всего откопали баг. Знаете почему?...
Потому что св-во Tabs имеет тип: TStrings а не TStringList.
в TStringList процедуры помещения и возврата указателя на TObject перекрыты и возвращают реальный указатель... и помещают его туда...
Тогда как в TStrings нет И вообще TStrings - яв-ся классом от которого должны только наследовать на сколько я знаю из делфи...
Из за чего когда мы делаем типа этого:

Код: Выделить всё

TabControl.Tabs.AddObject(Description, TObject(ID));

Мы обращаемся к процедуре:

Код: Выделить всё

PutObject

Которая у TStrings выглядит так:

Код: Выделить всё

Procedure TStrings.PutObject(Index: Integer; AObject: TObject);

begin
  // Empty.
end;

Тобишь ваш код ни к чему не приводит вы сделали воздух...
Тогда как эта же процедура выглядит в TStringList так:

Код: Выделить всё

Procedure TStringList.PutObject(Index: Integer; AObject: TObject);

begin
  If (Index<0) or (INdex>=Fcount)  then
    Error (SListIndexError,Index);
  Changing;
  Flist^[Index].FObject:=AObject;
  Changed;
end; 

Тобишь мы вообще ни как не можешь средствами Tabs.AddObject поместить какой либо обьект в список(массив)...

Пример, то что сделали Вы + я добавил тоже самое но и при помощи TStringList
Результат на лицо с TStringList все работает.
Код формы:

Код: Выделить всё

unit Unit1; 

{$mode objfpc}{$H+}

interface

uses
  Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, ComCtrls,
  StdCtrls;

type

  { TForm1 }

  TForm1 = class(TForm)
    Button1: TButton;
    TabControl1: TTabControl;
    procedure Button1Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure TabControl1Change(Sender: TObject);
  private
    { private declarations }
  public
    { public declarations }
  end; 

var
  Form1: TForm1; 
  Str:TStringList;
implementation

{$R *.lfm}

{ TForm1 }

procedure TForm1.Button1Click(Sender: TObject);
var B:TButton;
begin
    if Str = nil then
    Str:= TStringList.Create;

    B:=TButton.Create(self);
    B.Tag:=10;
    TabControl1.Tabs.AddObject('Id=1',B);
    Str.AddObject('1',B);
end;

procedure TForm1.FormCreate(Sender: TObject);
begin

end;

procedure TForm1.TabControl1Change(Sender: TObject);
begin
    Caption:='';
    Caption:=IntToStr(TButton(TabControl1.Tabs.Objects[TabControl1.TabIndex]).Tag);
    Caption:=Caption+'  '+IntToStr(TButton(Str.Objects[0]).Tag);
end;

end.

Исходники прилагаются:

[Иван Шихалев]

И вообще TStrings - яв-ся классом от которого должны только наследовать на сколько я знаю из делфи...

Именно. И реально там объект другого класса, наследника. Так что на методы TStrings не надо смотреть — они перекрыты.

[Maxizar]

И реально там объект другого класса, наследника.

Не понял вот эту фразу, у меня у табс вот что:

Код: Выделить всё

property Tabs: TStrings read FTabs write SetTabs; 

отсюда и проблема у alexkam, вот еслиб там был TStringList и TabControl работал именно с ним, то не было бы и проблемы...
А так ни как мы напрямую без всяких перекрытий и других классов...
Вот еслибы было хоть что то в этом духе:

Код: Выделить всё

property Tabs: TStringsTabs read FTabs write SetTabs; 

Где:

Код: Выделить всё

TStringsTabs=class(TStrings) 
тру ля ля

Тогда да... но там написанно в лоб.... И по этому я считаю что это баг, либо имеллось ввиду что TabControl не должен иметь такой возможности...

[Mr.Smart]

Maxizar Вы немного не правы. Там механизм немного сложнее.
В свойстве Tabs содержится класс наследник от TStrings TTabControlNoteBookStrings, который реализует метод PutObject

Код: Выделить всё

...
constructor TCustomTabControl.Create(TheOwner: TComponent); 
...
  FTabs:=TTabControlNoteBookStrings.Create(Self);
...
end;
...
procedure TTabControlNoteBookStrings.PutObject(Index: Integer; AObject: TObject
  );
begin
  FNoteBook.Pages.Objects[Index]:=AObject;
end; 

FNoteBook имеет тип TNoteBook. У него Pages содержит TNBPages, который тоже наследник TStrings, но метод PutObject у него почему то не реализован!

Код: Выделить всё

...
  TCustomNotebook = class(TWinControl)     
...
    property Pages: TStrings read FAccess write SetPages;
...
end;

...

constructor TCustomNotebook.Create(TheOwner: TComponent);
...
  fAccess := TNBPages.Create(TListWithEvent(fPageList), Self);
...
end;

  TNBPages = class(TStrings)
...
    function GetObject(Index: Integer): TObject; override;
    procedure Put(Index: Integer; const S: String); override;
  public
    constructor Create(thePageList: TListWithEvent;
                       theNotebook: TCustomNotebook);
...
end;

[Maxizar]

Ээээ (пускаяю слюни)... А кто это так сделал (вопрос риторический) Вот разработчики мне кажется усложнили чтоб враги не догадались... А после чего багтрекер вечно красный.. надо проще делать... Не ну я нигде не видел, чтобы автор скажем советовал делать так, тип будет один, но будет переменная которая будет наследником певрого класса перекрывать некоторые методы и мы через него будет имитировать работы с первым... прям санта барбара (пускаю слюни второй раз)
Вот именно после таких вот выкрутасов я не могу выстроить у себя в голове правильную картину работы компоненнта... Слаб я для таких не линейных штук...
И почему нельзя было использовать сразу СтрингЛист... Сусанин у них чтоль есть...

[alexkam]

Выходит в TabControl нельзя добавить ID объекта?

[Maxizar]

Выходит в TabControl нельзя добавить ID объекта?

Пока не допишут метод, который должен быть перекрыт. Метод про который говорил Mr.Smart
Решение:
1- использовать, дополнительно массив с обьектами.. тобишь делать все самому
2- использовать скажем как я StringList. Тобишь вдобавок TabControl,
3 - дописать самому метод который добавляет оъект к табу...

[alexkam]

Можно пример кода привязки объекта к TabControl?

[Maxizar]

Можно пример кода привязки объекта к TabControl?

Ну если считать, что метод не дописан или кривой, предлагаю связку TTabControl+ TStringList, ну как я писал выше... Пример написан просто в лоб, так что если есть табы до создания, нужно так же инициализировать и TStringList соответствующим образом либо проверять чтоб не выйти за диапазоны индексов...

Код: Выделить всё

unit Unit1; 

{$mode objfpc}{$H+}

interface

uses
  Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, ComCtrls,
  StdCtrls;

type

  { TForm1 }

  TForm1 = class(TForm)
    Button1: TButton;
    TabControl1: TTabControl;
    procedure Button1Click(Sender: TObject);
    procedure FormClose(Sender: TObject; var CloseAction: TCloseAction);
    procedure FormCreate(Sender: TObject);
    procedure TabControl1Change(Sender: TObject);
  private
    { private declarations }
  public
    function AddTab(const NameTab:String; AObject:TObject):Integer;
    { public declarations }
  end; 

var
  Form1: TForm1; 
  Tab:TStringList;
implementation

{$R *.lfm}

{ TForm1 }

procedure TForm1.FormCreate(Sender: TObject);
begin
  Tab:=TStringList.Create;
end;

procedure TForm1.TabControl1Change(Sender: TObject);
begin
  caption:=IntToStr(TabControl1.TabIndex)+'  ';
  caption:=caption+TButton(Tab.Objects[TabControl1.TabIndex]).Caption;
end;

procedure TForm1.FormClose(Sender: TObject; var CloseAction: TCloseAction);
begin
  Tab.Free;
end;

procedure TForm1.Button1Click(Sender: TObject);
var B1:TButton;
begin
    B1:=TButton.Create(Self);
    B1.Caption:='Button'+IntToStr(Tab.Count);
    AddTab(B1.Caption,B1);
end;

function TForm1.AddTab(const NameTab: String; AObject: TObject):Integer;
begin
  Result:=Tab.AddObject(NameTab,AObject);
  TabControl1.Tabs.Add(NameTab);
end;

end.

По идее так должно было работать из коробки, но разрабы все усложнили, зачем хз.. я бы сделал все через TStringList. А они наплодили дополнительные классы, которые еще и не дописаны.. Возможно есть мега планы на версию лазаруса типа 5.0 где будут мега отличия. Так что решать вам, что использовать.