-
Доброго времени стуок Сделал компонент с коллекцией для хранения настроек колонок в гриде
type
TFieldControlItem = class(TCollectionItem)
private
FFieldName: string; FComponentName: string; FCaption: string; FWidth: integer; FMayBeVisible: Boolean; FWithoutFilter: Boolean; protected
function GetDisplayName: string; override;
published
property FieldName: string read FFieldName write FFieldName;
property ComponentName: string read FComponentName write FComponentName;
property Caption: string read FCaption write FCaption;
property Width: integer read FWidth write FWidth default 50;
property MayBeVisible: boolean read FMayBeVisible write FMayBeVisible default true;
property WithoutFilter: boolean read FWithoutFilter write FWithoutFilter default false;
end;
TFieldControlItemCalss = class of TFieldControlItem;
TFieldControlList = class;
TFieldControls = class(TOwnedCollection)
private
FFieldControlList: TFieldControlList;
function GetItem(Index: Integer): TFieldControlItem;
procedure SetItem(Index: Integer; const Value: TFieldControlItem);
protected
procedure Update(Item: TCollectionItem); override;
public
function Add: TFieldControlItem;
property Items[Index: Integer]: TFieldControlItem read GetItem write SetItem; default;
published
end;
TFieldControlList = class(TComponent)
private
FFieldControls: TFieldControls;
procedure SetFieldControl(const Value: TFieldControls);
protected
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
function IndexByFieldName(AFieldName: string): integer;
function VisibleByFieldName(AFieldName: string): boolean;
published
property FieldControls: TFieldControls read FFieldControls write SetFieldControl;
end;
procedure Register;
implementation
procedure Register;
begin
RegisterComponents('MyComp', [TFieldControlList]);
end;
function TFieldControlItem.GetDisplayName: string;
begin
Result := FFieldName;
if Result = '' then Result := inherited GetDisplayName;
end;
function TFieldControls.Add: TFieldControlItem;
begin
Result := TFieldControlItem(inherited Add);
end;
function TFieldControls.GetItem(Index: Integer): TFieldControlItem;
begin
Result := TFieldControlItem(inherited GetItem(Index))
end;
procedure TFieldControls.SetItem(Index: Integer; const Value: TFieldControlItem);
begin
inherited SetItem(Index, Value);
end;
procedure TFieldControls.Update(Item: TCollectionItem);
begin
inherited Update(Item);
end;
constructor TFieldControlList.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FFieldControls:= TFieldControls.Create(Self, TFieldControlItem);
end;
destructor TFieldControlList.Destroy;
begin
FFieldControls.Free;
inherited;
end;
function TFieldControlList.IndexByFieldName(AFieldName: string): integer;
begin
for Result:= 0 to FFieldControls.Count-1 do
if FFieldControls.GetItem(Result).FieldName = AFieldName then Exit;
Result:= -1;
end;
function TFieldControlList.VisibleByFieldName(AFieldName: string): boolean;
var i: integer;
begin
for i:= 0 to FFieldControls.Count-1 do
if FFieldControls.GetItem(i).FieldName = AFieldName then
begin
Result:= FFieldControls.GetItem(i).MayBeVisible;
Exit;
end;
Result:= false;
end;
procedure TFieldControlList.SetFieldControl(const Value: TFieldControls);
begin
FFieldControls.Assign(Value)
end;
Выкладываю его на форму, заполняю. Все отрабатывает нормально. Затем создаю потомка этой формы. Захожу в компонент на форме-потомке, данные в нем есть. Пытаюсь сохранить форму, вываливается ошибка и содержимое коллекции исчезает. Что сделал не так?
-
А текст ошибки секретный ?
-
текст ошибки Cannot assign a TFieldControlItem to a TFieldControlItem
[5009E719]{rtl150.bpl } Classes.TPersistent.AssignError (Line 4420, "Classes.pas" + 4) + $36 [5009E761]{rtl150.bpl } Classes.TPersistent.AssignTo (Line 4425, "Classes.pas" + 0) + $1 [5009E697]{rtl150.bpl } Classes.TPersistent.Assign (Line 4410, "Classes.pas" + 0) + $7 [5009EE26]{rtl150.bpl } Classes.TCollection.Assign (Line 4699, "Classes.pas" + 10) + $16 [21063606]{designide150.bpl} Update.TUpdateObject.Update (Line 1126, "Update.pas" + 54) + $E [500375B3]{rtl150.bpl } System.@ReallocMem (Line 3935, "System.pas" + 85) + $0 [5009D49C]{rtl150.bpl } Classes.TList.SetCapacity (Line 3777, "Classes.pas" + 5) + $9 [5009D227]{rtl150.bpl } Classes.TList.Grow (Line 3615, "Classes.pas" + 7) + $4 [5009CFDF]{rtl150.bpl } Classes.TList.Add (Line 3514, "Classes.pas" + 3) + $4 [21063596]{designide150.bpl} Update.TUpdateObject.Update (Line 1112, "Update.pas" + 40) + $3 [50037560]{rtl150.bpl } System.@FreeMem (Line 3768, "System.pas" + 20) + $0 [5003A0D0]{rtl150.bpl } System.TObject.FreeInstance (Line 11050, "System.pas" + 2) + $2 [21061BB5]{designide150.bpl} Update.TChildUpdateObjects.Destroy (Line 364, "Update.pas" + 3) + $6 [5003A118]{rtl150.bpl } System.TObject.Free (Line 11069, "System.pas" + 1) + $4 [210631D2]{designide150.bpl} Update.UpdateOrder (Line 1028, "Update.pas" + 29) + $3 [2106363B]{designide150.bpl} Update.TUpdateObject.Update (Line 1131, "Update.pas" + 59) + $9 [50037560]{rtl150.bpl } System.@FreeMem (Line 3768, "System.pas" + 20) + $0 [5003A924]{rtl150.bpl } System.TMonitor.Destroy (Line 12347, "System.pas" + 0) + $0 [5003A193]{rtl150.bpl } System.TObject.CleanupInstance (Line 11189, "System.pas" + 20) + $0 [21064079]{designide150.bpl} Update.TUpdateManager.Update (Line 1462, "Update.pas" + 22) + $9 [2107AF5C]{designide150.bpl} ComponentDesigner.TComponentRoot.GetRootStream (Line 2760, "ComponentDesigner.pas" + 11) + $8 [2107FE0A]{designide150.bpl} ComponentDesigner.TComponentRoot.Save (Line 4734, "ComponentDesigner.pas" + 1) + $2 [21B8FB53]{delphicoreide150.bpl} DelphiModule.TPascalCodeMgrModHandler.SaveFile (Line 1474, "DelphiModule.pas" + 2) + $8 [208AF488]{coreide150.bpl} SourceModule.TCodeISourceModule.SaveFile (Line 1508, "SourceModule.pas" + 2) + $26 [208ACB30]{coreide150.bpl} SourceModule.TSourceModule.SaveFile (Line 653, "SourceModule.pas" + 3) + $23 [20A7475A]{coreide150.bpl} DocModul.TDocModule.TheMalteseFalcon (Line 1422, "DocModul.pas" + 60) + $6 [5013A3F5]{rtl150.bpl } Rtti.RawInvoke (Line 5538, "Rtti.pas" + 46) + $0 [5013A75A]{rtl150.bpl } Rtti.Invoke (Line 5729, "Rtti.pas" + 38) + $6 [501335D9]{rtl150.bpl } Rtti.TRttiInstanceMethodClassic.GetCallingConvention (Line 4103, "Rtti.pas" + 1) + $2 [50133F7F]{rtl150.bpl } Rtti.TRttiInstanceMethodEx.DispatchInvoke (Line 4408, "Rtti.pas" + 130) + $17 [5013ABC0]{rtl150.bpl } Rtti.TRttiMethod.Invoke (Line 5859, "Rtti.pas" + 1) + $11 [20A743C6]{coreide150.bpl} DocModul.TDocModule.Save (Line 1346, "DocModul.pas" + 3) + $23 [208ADC4F]{coreide150.bpl} SourceModule.TSourceModule.Save (Line 1002, "SourceModule.pas" + 13) + $B [2231511B]{delphide150.bpl} DelphiProject.TDelphiCodeIWin32Project._AddRef (Line 367, "DelphiProject.pas" + 1) + $1 [50040A1D]{rtl150.bpl } System.TInterfacedObject._AddRef (Line 28238, "System.pas" + 1) + $3 [20A79398]{coreide150.bpl} DocModul.SaveModifiedModules (Line 3554, "DocModul.pas" + 57) + $7 [0041D711]{bds.exe } Sanctuary.MD5.Transform (Line 282, "Sanctuary.MD5.pas" + 11) + $F [500AED6F]{rtl150.bpl } Classes.TBasicAction.Execute (Line 12988, "Classes.pas" + 3) + $7 [5026AA15]{vcl150.bpl } ActnList.TContainedAction.Execute (Line 448, "ActnList.pas" + 8) + $2C [5026B7F0]{vcl150.bpl } ActnList.TCustomAction.Execute (Line 1094, "ActnList.pas" + 7) + $8 [500AEC33]{rtl150.bpl } Classes.TBasicActionLink.Execute (Line 12917, "Classes.pas" + 2) + $7 [5029E788]{vcl150.bpl } Menus.TMenuItem.Click (Line 2525, "Menus.pas" + 17) + $7 [502A0113]{vcl150.bpl } Menus.DoClick (Line 3609, "Menus.pas" + 41) + $4 [502A01FF]{vcl150.bpl } Menus.TMenu.IsShortCut (Line 3662, "Menus.pas" + 38) + $6 [004238ED]{bds.exe } Sanctuary.Util.LaunchProcess (Line 1821, "Sanctuary.Util.pas" + 20) + $43 [50354A74]{vcl150.bpl } Forms.TCustomForm.IsShortCut (Line 6885, "Forms.pas" + 2) + $16 [50284CC0]{vcl150.bpl } Controls.TWinControl.IsMenuKey (Line 11464, "Controls.pas" + 13) + $C [50284D0D]{vcl150.bpl } Controls.TWinControl.CNKeyDown (Line 11479, "Controls.pas" + 5) + $4 [5027DF6C]{vcl150.bpl } Controls.TControl.WndProc (Line 7074, "Controls.pas" + 91) + $6 [50282830]{vcl150.bpl } Controls.TWinControl.WndProc (Line 9831, "Controls.pas" + 144) + $6 [211973B3]{vclide150.bpl} IDEInspListBox.TPropInspEdit.WndProc (Line 360, "IDEInspListBox.pas" + 7) + $4 [50281ED0]{vcl150.bpl } Controls.TWinControl.MainWndProc (Line 9552, "Controls.pas" + 3) + $6 [500AFA64]{rtl150.bpl } Classes.StdWndProc (Line 13491, "Classes.pas" + 8) + $0 [5035882C]{vcl150.bpl } Forms.TApplication.IsKeyMsg (Line 9668, "Forms.pas" + 25) + $12 [503588BA]{vcl150.bpl } Forms.TApplication.IsHintMsg (Line 9688, "Forms.pas" + 2) + $10 [50358AD3]{vcl150.bpl } Forms.TApplication.ProcessMessage (Line 9754, "Forms.pas" + 17) + $31 [50358B3A]{vcl150.bpl } Forms.TApplication.HandleMessage (Line 9790, "Forms.pas" + 1) + $4 [50358E65]{vcl150.bpl } Forms.TApplication.Run (Line 9927, "Forms.pas" + 26) + $3
-
Ах да, забыл, делаю на Delphi XE Но и в D7 такая же картинка
-
> Cannot assign a TFieldControlItem to a TFieldControlItem
Ну так напишите метод Assign procedure TFieldControlItem.Assign(Source: TPersistent);
begin
if Source is TFieldControlItem then begin
FieldName := TFieldControlItem(Source).FieldName;
...
end
else inherited Assign(Source);
end;
-
Я все же склонен перекрывать не Assign, а AssignTo. Потому что, если перекрыт только Assign, то вызов AssignTo всегда даст ошибку - а этого быть не должно.
-
Так до inherited Assign(Source); дело не дойдёт и соответственно AssignTo не вызовется. Для надёжности можно вообще убрать procedure TFieldControlItem.Assign(Source: TPersistent);
begin
if Source is TFieldControlItem then begin
FieldName := TFieldControlItem(Source).FieldName;
...
end
end;
-
Огромное спасибо. Все заработало.
-
Сразу еще вопрос. Как сделать так, чтобы редактирование коллекции открывалось при двойному клику по компоненту на форме, а не только через инспектор?
-
-
> DimaBr © (03.11.13 20:46) [6] Так ведь никто не мешает юзеру (т.е. прикладнику) вызвать AssignTo самому, из любого места кода. И если AssignTo не перекрыт, то будет исключение, даже если вызов был вполне корректен. А если AssignTo перекрыть (даже не перекрывая Assign), то и Assign, и AssignTo всегда будут работать правильно.
>baghin © (05.11.13 09:17) [8] Написать редактор компонента.
-
> Юрий Зотов
Юзеру вообще ничего не мешает грохнуть компонент, а потом к нему обращаться
-
> DimaBr © (06.11.13 14:58) [11]
За некорректную работу с компонентом сам юзер и отвечает.
Но вызов юзером AssignTo вполне корректен, а при корректной работе с компонентом он глючить не должен, и отвечает за это разработчик компонента.
-
Не согласен ! Assign - присвоить себе подобному AssignTo - присвоить чужеродному
В данном случае нужно себе подобному, а на чужеродном пусть валится ошибкой. А вообще , мне кажется, ТС это вообще не интересно, он не проявляет с своему вопросу никакого внимания
-
> DimaBr © (06.11.13 23:52) [13] > Assign - присвоить себе подобному > AssignTo - присвоить чужеродному
С какой радости? И то, и другое - просто присвоить одно другому. А разобраться кто свой, кто чужой и что с ним делать - это должен сам код. Вариант 1. Есть TMyClass. В нем замещен только Assign: procedure TMyClass.Assign(Source: TPersistent);
begin
if Source is TMyClass then
begin
...
end
else inherited
end; Теперь Assign работает правильно, а вот AssignTo работает неправильно. Потому что при вызове AssignTo(экземпляр_TMyClass) получим ошибку, хотя при таком вызове никакой ошибки быть не должно. Вариант 2. Есть TMyClass. В нем замещен только AssignTo: procedure TMyClass.AssignTo(Dest: TPersistent);
begin
if Dest is TMyClass then
begin
...
end
else inherited
end; Теперь можем вызывать хоть Assign, хоть AssignTo - все и всегда работает правильно. Для родного класса выполняет присвоение, для чужого выдает ошибку. Что и требовалось.
-
Метод AssignTo - protected и его "пользователь" вызвать не может (только в наследнике) А вообще в справке написано For example, given the following code in which A and B are instance variables:
A.Assign(B);
if A knows how to handle B, then it does so and returns. If A doesn’t know how to handle B’s type, execution will trickle to the TPersistent version of Assign, which calls:
B.AssignTo(A);
If B knows how to copy to A, the assignment succeeds. Otherwise, TPersistent raises an exception. Если А знает, как присвоить B , то всё ОК, так и делаем. Если не знает, то спускаемся к TPersisten, где спросим у самого В как присвоиться А. Метод AssignTo нужен для того чтобы научить незыблемые (например стандартные) компоненты получать значения из моих совершенно левых компонентов. Например, я хочу научить TEdit получать текст от заголовка моей формы. Класс TEdit я изменить не могу, но зато я могу изменить класс моей формы
TForm1 = class(TForm)
Edit1: TEdit;
procedure FormClick(Sender: TObject);
private
protected
procedure AssignTo(Dest: TPersistent);override;
end;
procedure TForm1.AssignTo(Dest: TPersistent);
begin
if Dest is TEdit then TEdit(Dest).Text := Caption else inherited;
end;
procedure TForm1.FormClick(Sender: TObject);
begin
Edit1.Assign(Form1);
end;
-
> DimaBr © (08.11.13 00:53) [15]
Одно другому не мешает. Но спорить действительно смысла нет - у нас разные исходные позиции. Ты считаешь, что ошибка при совершенно корректном вызове AssignTo - это нормально, я считаю - что ненормально.
-
Всем доброго времени суток
Пришлось переключится но другой проект
В результате экспериментов пришел к следующим результатам: 1. При использовании AssignTo коллекция наследовалась но при сохранении и открытии проекта снова не сохранялись данные в записях коллекции. их число соответствовало введенному, но без измененных параметров. 2. При использовании только Assign происходило следующее. Заполняем коллекцию на родителе. Создаем наследника. Сохраняем все. В предке добавляем еще одну запись. В наследнике она не появляется. 3. Если перекрывать обе процедуры то описанное выше отрабатывает нормально.
-
Дальнейшие эксперименты привели к еще одной проблеме Исходные данные: Предок с компонентом и заполненной коллекцией Потомок. В нем коллекция не менялась Если попытаться удалить одну из записей в коллекции предка, выдает ошибку Selection conttains a component introduced in an ancestor form which cannot be deleted Куда дальше копать Исходный код сейчас выглядит так type
TFormulaKind = (fkNone, fkCount, fkMaximum, fkMinimum, fkSum);
TFieldControlItem = class(TCollectionItem)
private
FFieldName: string; FComponentName: string; FCaption: string; FWidth: integer; FMayBeVisible: Boolean; FWithFilter: Boolean; FFormulaKind: TFormulaKind; protected
function GetDisplayName: string; override;
procedure AssignTo(Dest: TPersistent); override;
public
constructor Create(Collection: TCollection); override;
procedure Assign(Source: TPersistent); override;
published
property FieldName: string read FFieldName write FFieldName;
property ComponentName: string read FComponentName write FComponentName;
property Caption: string read FCaption write FCaption;
property Width: integer read FWidth write FWidth;
property MayBeVisible: boolean read FMayBeVisible write FMayBeVisible;
property WithFilter: boolean read FWithFilter write FWithFilter;
property FormulaGroup: TFormulaKind read FFormulaKind write FFormulaKind;
end;
TFieldControlItemCalss = class of TFieldControlItem;
TFieldControlList = class;
TFieldControls = class(TOwnedCollection)
private
FFieldControlList: TFieldControlList;
function GetItem(Index: Integer): TFieldControlItem;
procedure SetItem(Index: Integer; const Value: TFieldControlItem);
protected
procedure Update(Item: TCollectionItem); override;
public
function Add: TFieldControlItem;
property Items[Index: Integer]: TFieldControlItem read GetItem write SetItem; default;
published
end;
TFieldControlList = class(TComponent)
private
FFieldControls: TFieldControls;
procedure SetFieldControl(const Value: TFieldControls);
protected
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
function IndexByFieldName(AFieldName: string): integer;
function VisibleByFieldName(AFieldName: string): boolean;
published
property FieldControls: TFieldControls read FFieldControls write SetFieldControl;
end;
procedure Register;
implementation
procedure Register;
begin
RegisterComponents('Terminal', [TFieldControlList, TImageGIF]);
end;
procedure TFieldControlItem.AssignTo(Dest: TPersistent);
begin
if Dest is TFieldControlItem then
begin
FieldName:= TFieldControlItem(Dest).FieldName;
ComponentName:= TFieldControlItem(Dest).ComponentName;
Caption:= TFieldControlItem(Dest).Caption;
Width:= TFieldControlItem(Dest).Width;
MayBeVisible:= TFieldControlItem(Dest).MayBeVisible;
WithFilter:= TFieldControlItem(Dest).WithFilter;
FormulaGroup:= TFieldControlItem(Dest).FormulaGroup;
end
else inherited AssignTo(Dest);
end;
procedure TFieldControlItem.Assign(Source: TPersistent);
begin
if Source is TFieldControlItem then
begin
FieldName:= TFieldControlItem(Source).FieldName;
ComponentName:= TFieldControlItem(Source).ComponentName;
Caption:= TFieldControlItem(Source).Caption;
Width:= TFieldControlItem(Source).Width;
MayBeVisible:= TFieldControlItem(Source).MayBeVisible;
WithFilter:= TFieldControlItem(Source).WithFilter;
FormulaGroup:= TFieldControlItem(Source).FormulaGroup;
end
else inherited Assign(Source);
end;
constructor TFieldControlItem.Create(Collection: TCollection);
begin
inherited;
FFieldName:= '';
FComponentName:= '';
FCaption:= '';
FWidth:= 50;
FMayBeVisible:= true;
FWithFilter:= false;
FFormulaKind:= fkNone;
end;
function TFieldControlItem.GetDisplayName: string;
begin
Result := FFieldName;
if Result = '' then Result := inherited GetDisplayName;
end;
function TFieldControls.Add: TFieldControlItem;
begin
Result := TFieldControlItem(inherited Add);
end;
function TFieldControls.GetItem(Index: Integer): TFieldControlItem;
begin
Result := TFieldControlItem(inherited GetItem(Index))
end;
procedure TFieldControls.SetItem(Index: Integer; const Value: TFieldControlItem);
begin
inherited SetItem(Index, Value);
end;
procedure TFieldControls.Update(Item: TCollectionItem);
begin
inherited Update(Item);
end;
constructor TFieldControlList.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FFieldControls:= TFieldControls.Create(Self, TFieldControlItem);
end;
destructor TFieldControlList.Destroy;
begin
FFieldControls.Free;
inherited;
end;
function TFieldControlList.IndexByFieldName(AFieldName: string): integer;
begin
for Result:= 0 to FFieldControls.Count-1 do
if FFieldControls.GetItem(Result).FieldName = AFieldName then Exit;
Result:= -1;
end;
function TFieldControlList.VisibleByFieldName(AFieldName: string): boolean;
var i: integer;
begin
for i:= 0 to FFieldControls.Count-1 do
if FFieldControls.GetItem(i).FieldName = AFieldName then
begin
Result:= FFieldControls.GetItem(i).MayBeVisible;
Exit;
end;
Result:= false;
end;
procedure TFieldControlList.SetFieldControl(const Value: TFieldControls);
begin
FFieldControls.Assign(Value)
end;
-
Дополнение
В случае зачистки записи в dfm файле она исчезает в потомке
|