VCL Framework 的核心组件基础类TComponent,提供的基础服务:
*作为基础根组件类以及基础组建管理功能
*可同时扮演Container组件和单一组件的功能
*基础组件互动通知功能(Notification)
*同时提供可视化和非可视化组件构架基础
1.作为基础根组件类以及基础组建管理功能
TComponent作为组件类的根类自然需要声明虚拟构造函数和虚拟析构函数以便让派生类可以改写。
constructor Create(AOwner: TComponent); virtual;
destructor Destroy; override;
begin
FComponentStyle : = [csInheritable];
if AOwner <> nil then AOwner.InsertComponent(Self);
end ;
2 begin
3 Destroying;
4 if FFreeNotifies <> nil then
5 begin
6 while Assigned(FFreeNotifies) and (FFreeNotifies.Count > 0 ) do
7 TComponent(FFreeNotifies[FFreeNotifies.Count - 1 ]).Notification(Self, opRemove);
8 FreeAndNil(FFreeNotifies);
9 end ;
10 DestroyComponents;
11 if FOwner <> nil then FOwner.RemoveComponent(Self);
12 inherited Destroy;
13 end ;
tcomponent实现了基础组件管理服务,这些方法是InsertComponent、RemoveComponent、components等相关特性。
2.可同时扮演Container组件和单一组件的功能
private
FOwner: TComponent; // 父代对象
FName: TComponentName;
FTag: Longint;
FComponents: TList; // 存储所有它管理的子组件
3.基础组件互动通知功能(Notification)
采用了Notify设计模式来管理子组件,在 TComponent的构造函数中调用了父代对象的InsertComponent来通知一个新的TComponent对象的加入。在005行中把新的子 组件加入到FComponents中,在009行中调用Notification通知FComponents中的每个组件现在有新的组件加入了。
2 begin
3 AComponent.ValidateContainer(Self);
4 ValidateRename(AComponent, ' ', AComponent.FName);
5 Insert(AComponent);
6 AComponent.SetReference( True );
7 if csDesigning in ComponentState then
8 AComponent.SetDesigning( True );
9 Notification(AComponent, opInsert);
10 end ;
11
12 procedure TComponent.Insert(AComponent: TComponent);
13 begin
14 if FComponents = nil then FComponents : = TList.Create;
15 FComponents.Add(AComponent);
16 AComponent.FOwner : = Self;
17 end ;
18
19 procedure TComponent.Notification(AComponent: TComponent;
20 Operation: TOperation);
21 var
22 I: Integer ;
23 begin
24 if (Operation = opRemove) and (AComponent <> nil) then
25 RemoveFreeNotification(AComponent);
26 if FComponents <> nil then
27 begin
28 I : = FComponents.Count - 1 ;
29 while I >= 0 do
30 begin
31 TComponent(FComponents[I]).Notification(AComponent, Operation);
32 Dec(I);
33 if I >= FComponents.Count then
34 I : = FComponents.Count - 1 ;
35 end ;
36 end ;
37 end ;
TComponent的Notitication声明成虚拟方法。
TComponent另一个基础管理组件服务RemoveComponent,同样使用Notify设计模式知会子组件有组件被释放了,在通知完所有相关组件之后才会调用Remove真正把组件从FComponents中移除。
begin
ValidateRename(AComponent, AComponent.FName, ' ');
Notification(AComponent, opRemove);
AComponent.SetReference( False );
Remove(AComponent);
end ;
procedure TComponent.Remove(AComponent: TComponent);
begin
AComponent.FOwner : = nil;
FComponents.Remove(AComponent);
if FComponents.Count = 0 then
begin
FComponents.Free;
FComponents : = nil;
end ;
end ;
var
Ancestor: TComponent;
Info: Longint;
begin
Info : = 0 ;
Ancestor : = TComponent(Filer.Ancestor);
if Ancestor <> nil then Info : = Ancestor.FDesignInfo;
Filer.DefineProperty( ' Left', ReadLeft, WriteLeft,
LongRec(FDesignInfo).Lo <> LongRec(Info).Lo);
Filer.DefineProperty( ' Top', ReadTop, WriteTop,
LongRec(FDesignInfo).Hi <> LongRec(Info).Hi);
end ;
2 private
3 FOwner: TComponent;
4 FName: TComponentName;
5 FTag: Longint;
6 FComponents: TList;
7 FFreeNotifies: TList;
8 FDesignInfo: Longint;
9 FComponentState: TComponentState;
10
11 FVCLComObject: Pointer;
12 function GetComObject: IUnknown;
13
14 function GetComponent(AIndex: Integer ): TComponent;
15 function GetComponentCount: Integer ;
16 function GetComponentIndex: Integer ;
17 procedure Insert(AComponent: TComponent);
18 procedure ReadLeft(Reader: TReader);
19 procedure ReadTop(Reader: TReader);
20 procedure Remove(AComponent: TComponent);
21 procedure RemoveNotification(AComponent: TComponent);
22 procedure SetComponentIndex(Value: Integer );
23 procedure SetReference(Enable: Boolean );
24 procedure WriteLeft(Writer: TWriter);
25 procedure WriteTop(Writer: TWriter);
26 { IInterfaceComponentReference }
27 function IInterfaceComponentReference.GetComponent = IntfGetComponent;
28 function IntfGetComponent: TComponent;
29 protected
30 FComponentStyle: TComponentStyle;
31 procedure ChangeName( const NewName: TComponentName);
32 procedure DefineProperties(Filer: TFiler); override;
33 procedure GetChildren(Proc: TGetChildProc; Root: TComponent); dynamic;
34 function GetChildOwner: TComponent; dynamic;
35 function GetChildParent: TComponent; dynamic;
36 function GetOwner: TPersistent; override;
37 procedure Loaded; virtual;
38 procedure Notification(AComponent: TComponent;
39 Operation: TOperation); virtual;
40 procedure PaletteCreated; dynamic;
41 procedure ReadState(Reader: TReader); virtual;
42 procedure SetAncestor(Value: Boolean );
43 procedure SetDesigning(Value: Boolean ; SetChildren: Boolean = True );
44 procedure SetInline(Value: Boolean );
45 procedure SetDesignInstance(Value: Boolean );
46 procedure SetName( const NewName: TComponentName); virtual;
47 procedure SetChildOrder(Child: TComponent; Order: Integer ); dynamic;
48 procedure SetParentComponent(Value: TComponent); dynamic;
49 procedure Updating; dynamic;
50 procedure Updated; dynamic;
51 class procedure UpdateRegistry(Register: Boolean ; const ClassID, ProgID: string ); virtual;
52 procedure ValidateRename(AComponent: TComponent;
53 const CurName, NewName: string ); virtual;
54 procedure ValidateContainer(AComponent: TComponent); dynamic;
55 procedure ValidateInsert(AComponent: TComponent); dynamic;
56 procedure WriteState(Writer: TWriter); virtual;
57 { IInterface }
58 function QueryInterface( const IID: TGUID; out Obj): HResult; virtual; stdcall;
59 function _AddRef: Integer ; stdcall;
60 function _Release: Integer ; stdcall;
61
62 { IDispatch }
63 function GetTypeInfoCount(out Count: Integer ): HResult; stdcall;
64 function GetTypeInfo(Index, LocaleID: Integer ; out TypeInfo): HResult; stdcall;
65 function GetIDsOfNames( const IID: TGUID; Names: Pointer;
66 NameCount, LocaleID: Integer ; DispIDs: Pointer): HResult; stdcall;
67 function Invoke(DispID: Integer ; const IID: TGUID; LocaleID: Integer ;
68 Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HResult; stdcall;
69
70 public
71 constructor Create(AOwner: TComponent); virtual;
72 destructor Destroy; override;
73 procedure BeforeDestruction; override;
74 procedure DestroyComponents;
75 procedure Destroying;
76 function ExecuteAction(Action: TBasicAction): Boolean ; dynamic;
77 function FindComponent( const AName: string ): TComponent;
78 procedure FreeNotification(AComponent: TComponent);
79 procedure RemoveFreeNotification(AComponent: TComponent);
80
81 procedure FreeOnRelease;
82
83 function GetParentComponent: TComponent; dynamic;
84 function GetNamePath: string ; override;
85 function HasParent: Boolean ; dynamic;
86 procedure InsertComponent(AComponent: TComponent);
87 procedure RemoveComponent(AComponent: TComponent);
88 procedure SetSubComponent(IsSubComponent: Boolean );
89 function SafeCallException(ExceptObject: TObject;
90 ExceptAddr: Pointer): HResult; override;
91 function UpdateAction(Action: TBasicAction): Boolean ; dynamic;
92 function IsImplementorOf( const I: IInterface): Boolean ;
93 function ReferenceInterface( const I: IInterface; Operation: TOperation): Boolean ;
94
95 property ComObject: IUnknown read GetComObject;
96
97 property Components[Index: Integer ]: TComponent read GetComponent;
98 property ComponentCount: Integer read GetComponentCount;
99 property ComponentIndex: Integer read GetComponentIndex write SetComponentIndex;
100 property ComponentState: TComponentState read FComponentState;
101 property ComponentStyle: TComponentStyle read FComponentStyle;
102 property DesignInfo: Longint read FDesignInfo write FDesignInfo;
103 property Owner: TComponent read FOwner;
104
105 property VCLComObject: Pointer read FVCLComObject write FVCLComObject;
106
107 published
108 property Name: TComponentName read FName write SetName stored False ;
109 property Tag: Longint read FTag write FTag default 0 ;
110 end ;