1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148
|
unit Unit2;
interface
uses
classes, sysUtils, Dialogs;
type
TmyClass = class
private
Fx : double;
function GetX: double;
procedure SetX(const Value: double);
public
property x : double read GetX write SetX;
class function New(Param : string):TmyClass;
end;
TmyClass1 = class
private
Fc : char;
function GetC: char;
procedure SetC(const Value: char);
public
property c : char read GetC write SetC;
class function New(Param : string):TObject; virtual;
{Si aucune classe n'hérite de TMyClass1 on peut définir New ainsi :
class function New(Param : string):TmyClass1; }
end;
TmyClass1Deriv = class(TmyClass1)
public
class function New(Param : string):TObject; override;
end;
procedure test;
implementation
{ TmyClass }
function TmyClass.GetX: double;
begin
Result := Fx;
end;
class function TmyClass.New(Param: string): TmyClass;
begin
Result := Create;
with Result do begin
Fx := Length(Param);
end;
end;
procedure TmyClass.SetX(const Value: double);
begin
Fx := Value;
end;
{ TmyClass1 }
function TmyClass1.GetC: char;
begin
Result := Fc;
end;
class function TmyClass1.New(Param: string): TObject;
begin
Result := Create;
with TmyClass1(Result) do begin
if Length(Param) > 0 then
Fc := Param[1]
else
Fc := #0;
end;
end;
procedure TmyClass1.SetC(const Value: char);
begin
Fc := Value;
end;
{ TmyClass1Deriv }
class function TmyClass1Deriv.New(Param: string): TObject;
begin
Result := Create;
with TmyClass1Deriv(Result) do begin
if Length(Param) > 0 then
Fc := Param[Length(Param)]
else
Fc := '.';
end;
end;
function StrValueFmt(AObject: TObject):string;
begin
with AObject.ClassType do begin
if InheritsFrom(TmyClass)
then Result := Format('%s : %g',[ClassName,TmyClass(AObject).x])
else
if
{Traiter le cas de la classe dérivée avant le cas de la classe "ancêtre"}
InheritsFrom(TmyClass1Deriv)
then Result := Format('%s dérivée de %s : %s',
[ClassName,ClassParent.ClassName,TmyClass1(AObject).c])
else
if
InheritsFrom(TmyClass1)
then Result := Format('%s : %s',[ClassName,TmyClass1(AObject).c])
else Result := Format('Other type %s',[ClassName]);
end;
end;
var
List: TStringList;
procedure test;
procedure AddItem(AObject: TObject);
begin
List.AddObject(StrValueFmt(AObject),AObject);
end;
begin
List:= TStringList.Create;
with List do
try
AddItem(TmyClass.New('abcdef'));
AddItem(TmyClass1.New('abcdef'));
AddItem(TmyClass1Deriv.New('abcdef'));
{Aperçu du contenu de la liste}
ShowMessage(Text);
finally
{Liberér les items
........}
{Libérer la liste}
Free;
end;
end;
end. |
Partager