I wonder if it is possible to define a default property value to a component.
In another words, I want to set, in design time, an unique name (maybe GUID) to each TDBGrid in the system, is it possible? There is another way to control uniqueness of a component that works both in runtime and design time. Also it must persists after I close delphi; e.g combobox list values.
Thanks in advance!
edit
below is the code, that is not working:
type
TMDBGrid = class(TDBGrid)
private
FUniqueName: String;
protected
function DefaultUniqueName: String;
function GetUniqueName: String;
procedure SetUniqueName(const AName: String);
public
constructor Create(AOwner: TComponent); override;
published
property UniqueName: String read GetUniqueName write SetUniqueName;
end;
procedure Register;
implementation
uses uComponentUtils;
procedure Register;
begin
RegisterComponents('MLStandard', [TMDBGrid]);
end;
{ TMDBGrid }
constructor TMDBGrid.Create(AOwner: TComponent);
begin
inherited;
FUniqueName := DefaultUniqueName;
end;
function TMDBGrid.DefaultUniqueName: String;
begin
Result := GenerateGUID(True);
end;
function TMDBGrid.GetUniqueName: String;
begin
Result := '';
end;
procedure TMDBGrid.SetUniqueName(const AName: String);
begin
FUniqueName := AName;
if FUniqueName = '' then
FUniqueName := DefaultUniqueName;
end;
function GenerateGUID(PlainText: Boolean = False): String;
var G: TGUID;
begin
CreateGUID(G);
Result:= GUIDToString(G);
if PlainText then
Result := MultiStringReplace(Result, ['{','}','[',']','-','.',' ','(',')'],
['','','','','','','','',''],
[rfReplaceAll, rfIgnoreCase]);
end;
"It's not working" means when a TDBGrid is added to any form, UNIQUENAME is empty. It should have a GUID.
Your implementation of GetUniqueName does not return anything. It needs to return FUniqueName.
function TMDBGrid.GetUniqueName: String;
begin
Result := FUniqueName;
end;
Or you could delete the getter and change the property to be like so:
property UniqueName: String read FUniqueName write SetUniqueName;
Related
I have a TRttiProperty variable named aRttiProperty, that points to the property below:
Tsubscription = class(TMyObject)
private
fBilling: TMyObject;
public
property billing: TMyObject read fBilling; // << aRttiProperty point to this member
end;
Now, how can I extract the fBilling object pointer from aRttiProperty?
I try to do it like this, but it is not working:
function Tsubscription.getfBillingObj(const aRttiProperty: TRttiProperty): TMyObject
begin
Result := aRttiProperty.GetValue(Self).AsType<TMyObject>;
end;
It's returning the parent TSubscription object instead of the fbilling field object.
The code you showed in your question is perfectly fine (provided you fix your Tsubscription class declaration to include the getfBillingObj() method). The getfBillingObj() code you showed returns the correct object pointer, as demonstrated by the following code:
uses
System.Rtti;
type
TMyObject = class
public
Name: string;
constructor Create(const aName: string);
end;
Tsubscription = class(TMyObject)
private
fBilling: TMyObject;
public
constructor Create(const aName: string);
destructor Destroy; override;
function getfBillingObj(const aRttiProperty: TRttiProperty): TMyObject;
property billing: TMyObject read fBilling;
end;
constructor TMyObject.Create(const aName: string);
begin
inherited Create;
Name := aName;
end;
constructor Tsubscription.Create(const aName: string);
begin
inherited Create(aName);
fBilling := TMyObject.Create('bill');
end;
destructor Tsubscription.Destroy;
begin
fBilling.Free;
end;
function Tsubscription.getfBillingObj(const aRttiProperty: TRttiProperty): TMyObject;
begin
Result := aRttiProperty.GetValue(Self).AsType<TMyObject>;
end;
var
Ctx: TRttiContext;
prop: TRttiProperty;
sub: Tsubscription;
bill: TMyObject;
begin
sub := Tsubscription.Create('sub');
try
prop := ctx.GetType(Tsubscription).GetProperty('billing');
bill := sub.getfBillingObj(prop);
// bill.Name is 'bill' as expected...
finally
sub.Free;
end;
end;
That being said, it is not necessary to use RTTI in this situation since TSubscription has direct access to its own internal fields:
function TSubscription.getfBillingObj: TMyObject
begin
Result := fBilling;
end;
But even that is redundant since the billing property is public. Any caller can just use the billing property as-is:
var
sub: Tsubscription;
bill: TMyObject;
begin
sub := Tsubscription.Create('sub');
try
bill := sub.billing;
// bill.Name is 'bill' as expected...
finally
sub.Free;
end;
end;
I have my own component (TNiftyRVFrameWithPopups) with a TOwnedCollection as a property (TagList).
Every time I add items to TagList the same item should be added to another object (FMenu). This is performed by the procedure RefreshMenu called from TNiftyRVFrameWithPopups.Loaded on design time.
My issue is I cannot add items on runtime, because TNiftyRVFrameWithPopups.Loaded is not called.
I thought one solution would be Postmessage but I didn't manage to make it work.
The following is the source:
TNiftyListTag = class(TCollectionItem)
private
FTagValue: string;
FDisplayTextTag: string;
public
procedure Assign(Source: TPersistent); override;
published
property DisplayTag: string read FDisplayTextTag write FDisplayTextTag;
property Value: string read FTagValue write FTagValue;
end;
TNiftyListTags = class(TOwnedCollection)
protected
function GetItem(Index: Integer): TNiftyListTag;
procedure SetItem(Index: Integer; Value: TNiftyListTag);
public
constructor Create(AOwner: TPersistent; ItemClass: TCollectionItemClass);
function Add: TNiftyListTag;
end;
TNiftyRVFrameWithPopups = class(TRVEditFrame)
private
FMenu: TAdvSmoothListBox;
FMenuList: TStringList;
FCollectionTags: TNiftyListTags;
procedure SetCollectionTags(const Value: TNiftyListTags);
procedure RefreshMenu;
public
{ Public declarations }
constructor Create(AOwner: TComponent); override;
procedure Loaded; override;
published
property TagList: TNiftyListTags read FCollectionTags write SetCollectionTags;
end;
implementation
constructor TNiftyRVFrameWithPopups.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FMenuList := TStringList.Create;
FCollectionTags := TNiftyListTags.Create(Self, TNiftyListTag);
end;
procedure TNiftyRVFrameWithPopups.SetCollectionTags(const Value: TNiftyListTags);
begin
FCollectionTags.Assign(Value);
end;
procedure TNiftyRVFrameWithPopups.RefreshMenu;
var
i: Integer;
begin
FMenu.Items.Clear;
for i := 0 to FCollectionTags.Count - 1 do
begin
FMenu.Items.Add;
FMenu.Items.Items[i].Caption := FCollectionTags.Items[i].FDisplayTextTag;
end;
end;
procedure TNiftyRVFrameWithPopups.Loaded;
begin
inherited Loaded;
if Assigned(FRVEditor) then
begin
RefreshMenu;
end;
end;
{ TNiftyListTag }
procedure TNiftyListTag.Assign(Source: TPersistent);
begin
if Source is TNiftyListTag then
begin
FTagValue := TNiftyListTag(Source).FTagValue;
FDisplayTextTag := TNiftyListTag(Source).FDisplayTextTag;
end
else
inherited;
end;
{ TNiftyListTags }
function TNiftyListTags.Add: TNiftyListTag;
begin
Result := TNiftyListTag(inherited Add);
end;
constructor TNiftyListTags.Create(AOwner: TPersistent; ItemClass: TCollectionItemClass);
begin
inherited Create(AOwner, ItemClass);
end;
procedure TNiftyListTags.SetItem(Index: Integer; Value: TNiftyListTag);
begin
inherited SetItem(index, Value);
end;
function TNiftyListTags.GetItem(Index: Integer): TNiftyListTag;
begin
Result := TNiftyListTag(inherited GetItem(Index));
end;
EDIT
After Deltics' advice I have amended my code:
TNiftyListTag = class(TCollectionItem)
private
FTagValue: string;
FDisplayTextTag: string;
public
procedure Assign(Source: TPersistent); override;
published
property DisplayTag: string read FDisplayTextTag write FDisplayTextTag;
property Value: string read FTagValue write FTagValue;
end;
TNiftyListTags = class(TOwnedCollection)
private
fOnChanged: TNotifyEvent;
procedure DoOnChanged;
protected
function GetItem(Index: Integer): TNiftyListTag;
procedure SetItem(Index: Integer; Value: TNiftyListTag);
public
constructor Create(AOwner: TPersistent; ItemClass: TCollectionItemClass);
function Add: TNiftyListTag;
procedure AppendItem(const aDisplayText, aTag: string);
end;
TNiftyRVFrameWithPopups = class(TRVEditFrame)
private
FMenu: TAdvSmoothListBox;
FMenuList: TStringList;
FCollectionTags: TNiftyListTags;
procedure RefreshMenu;
procedure SetCollectionTags(const Value: TNiftyListTags);
public
{ Public declarations }
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
procedure Loaded; override;
published
property TagList: TNiftyListTags read FCollectionTags write SetCollectionTags;
end;
implementation
constructor TNiftyRVFrameWithPopups.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FMenuList := TStringList.Create;
FCollectionTags := TNiftyListTags.Create(Self, TNiftyListTag);
FCollectionTags.fOnChanged := RefreshMenu;
end;
destructor TNiftyRVFrameWithPopups.Destroy;
begin
FreeAndNil(FMenuList);
FCollectionTags.Free;
inherited;
end;
procedure TNiftyRVFrameWithPopups.RefreshMenu;
var
i: Integer;
begin
FMenu.Items.Clear;
for i := 0 to FCollectionTags.Count - 1 do
begin
FMenu.Items.Add;
FMenu.Items.Items[i].Caption := FCollectionTags.Items[i].FDisplayTextTag;
end;
end;
procedure TNiftyRVFrameWithPopups.Loaded;
begin
inherited Loaded;
RefreshMenu(Self);
end;
procedure TNiftyRVFrameWithPopups.RefreshMenu;
var
i: Integer;
begin
if Assigned(FRVEditor) then
begin
(FRVEditor as TCustomRichViewEdit).OnRVMouseUp := OnMouseUp;
FMenu.Parent := FRVEditor;
fmenu.Items.Clear;
for i := 0 to FCollectionTags.Count - 1 do
begin
FMenu.Items.Add;
FMenu.Items.Items[i].Caption := FCollectionTags.Items[i].FDisplayTextTag;
end;
end;
end;
procedure TNiftyRVFrameWithPopups.SetCollectionTags(const Value: TNiftyListTags);
begin
FCollectionTags.Assign(Value);
end;
{ TNiftyListTag }
procedure TNiftyListTag.Assign(Source: TPersistent);
begin
if Source is TNiftyListTag then
begin
FTagValue := TNiftyListTag(Source).FTagValue;
FDisplayTextTag := TNiftyListTag(Source).FDisplayTextTag;
end
else
inherited;
end;
{ TNiftyListTags }
function TNiftyListTags.Add: TNiftyListTag;
begin
Result := TNiftyListTag(inherited Add);
end;
procedure TNiftyListTags.AppendItem(const aDisplayText, aTag: string);
var
a: TNiftyListTag;
begin
a := TNiftyListTag(inherited Add);
a.FTagValue := aTag;
a.FDisplayTextTag := aDisplayText;
DoOnChanged;
end;
constructor TNiftyListTags.Create(AOwner: TPersistent; ItemClass: TCollectionItemClass);
begin
inherited Create(AOwner, ItemClass);
end;
procedure TNiftyListTags.DoOnChanged;
begin
if Assigned(fOnChanged) then
fOnChanged(self);
end;
procedure TNiftyListTags.SetItem(Index: Integer; Value: TNiftyListTag);
begin
inherited SetItem(index, Value);
end;
function TNiftyListTags.GetItem(Index: Integer): TNiftyListTag;
begin
Result := TNiftyListTag(inherited GetItem(Index));
end;
procedure TNiftyListTags.SetItem(Index: Integer; Value: TNiftyListTag);
begin
inherited SetItem(index, Value);
DoOnChanged;
end;
end.
Items can be added at run time in the following way:
var
a:TNiftyRVFrameWithPopups;
begin
a:=TNiftyRVFrameWithPopups.Create(self);
.....
a.TagList.AppendItem('a','b');
a.TagList.AppendItem('c','d');
end
Your TNiftyListTags is owned by the TNiftyRVFrameWithPopups.
Your only 'problem' is that the TOwnedCollection class does not provide a typed reference to the owner, by which to invoke the necessary method(s) to refresh the owner when the collection changes.
There are a number of ways to achieve what you want. However, before presenting options, whatever you do I suggest you do not call Loaded to achieve your update/refresh since this method has specific meaning. Whilst your code in the overridden method may be safe in this context, the inherited implementation may not be.
I would suggest moving the if Assigned(fRVEditor) pre-condition check to RefreshMenu itself. Loaded then simply calls RefreshMenu as may any other code that may need to also call RefreshMenu, with the necessary pre-condition checked by the method itself.
Now, as for how and when to call the RefreshMenu method, one simple mechanism is to directly invoke the refresh method whenever the content of the collection changes. e.g. in the Add method of the collection. Since you are using a TOwnedCollection as the base class, you could simply type-cast the Owner:
function TNiftyListTags.Add: TNiftyListTag;
begin
Result := TNiftyListTag(inherited Add);
TNiftyRVFrameWithPopups(Owner).RefreshMenu;
end;
However, this couples your collection class directly to the specific component acting as the owner. If your collection is specialised to this class specifically then this may be valid, but it is still undesirable.
To de-couple the collection from the component you could alternatively introduce an OnChange event on the collection. A simple TNotifyEvent will usually suffice.
Whichever component then owns the collection may then install a handler for this event. Whenever the collection changes, invoke the OnChange handler. In this case the TNiftyRVFrameWithPopups component will respond to those changes by calling its own RefreshMenu method.
procedure TNiftyListTags.DoOnChanged;
begin
if Assigned(fOnChanged) then
fOnChanged(self);
end;
function TNiftyListTags.Add: TNiftyListTag;
begin
Result := TNiftyListTag(inherited Add);
DoOnChanged;
end;
procedure TNiftyRVFrameWithPopups.OnTagsChanged(Sender: TObject);
begin
RefreshMenu;
end;
This is typically the approach I adopt and I make the OnChange event a private implementation detail, with the handler specified in the constructor by the component instantiating the collection. This prevents anyone from inadvertently replacing the event handler via any public property etc.
constructor TNiftyRVFrameWithPopups.Create(Owner: TComponent);
begin
inherited Create(self);
fTags := TNiftyListTags.Create(self, OnTagsChanged);
..
end;
To facilitate this you obviously need a custom constructor to accept the event handler:
TNiftyListTags = class(TOwnedCollection)
..
private
fOnChanged: TNotifyEvent;
public
constructor Create(aOwner: TPersistent; aOnChange: TNotifyEvent); reintroduce;
..
end;
constructor TNiftyListTags.Create(aOwner: TPersistent;
aOnChange: TNotifyEvent);
begin
inherited Create(aOwner, TNiftyListTag);
fOnChange := aOnChange;
end;
Note that the inherited constructor also accepts two parameters, the second being the class of the collection items. Sine you are introducing a custom constructor you can remove this from the parameters of your own constructor and simply specify the item class in the inherited Create call.
NOTE: This does not increase the coupling between the collection and the item class - they are already tightly coupled, by definition (and design).
I am writing this question for Delphi 2007, but I'm pretty sure that this is a common problem in all kind of languages.
So, I have a project where I need to keep informations about the old and new value of certain fields (which are given in the BeforePost event of the dataset I'm working with) and use them in the AfterPost event.
For now, I have been using global variables, but there is already so many of them in the project that this is becoming a real issue when it comes to managing documentation and/or comments.
Basically, I am asking if there is a better way (in Delphi 2007 or in general) to keep the informations from the BeforePost event of a Dataset and get them back in the AfterPost event.
first create a new Custom Data Source
TDataRecord = array of record
FieldName: string;
FieldValue: Variant;
end;
TMyDataSource = class(TDataSource)
private
LastValues: TDataRecord;
procedure MyDataSourceBeforePost(DataSet: TDataSet);
procedure SetDataSet(const Value: TDataSet);
function GetDataSet: TDataSet;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
function GetLastValue(FieldName: string): Variant;
property MyDataSet: TDataSet read GetDataSet write SetDataSet;
end;
{ TMyDataSource }
constructor TMyDataSource.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
end;
destructor TMyDataSource.Destroy;
begin
SetLength(LastValues, 0);
inherited Destroy;
end;
function TMyDataSource.GetDataSet: TDataSet;
begin
Result := DataSet;
end;
procedure TMyDataSource.SetDataSet(const Value: TDataSet);
begin
DataSet := Value;
DataSet.BeforePost := MyDataSourceBeforePost;
end;
procedure TMyDataSource.MyDataSourceBeforePost(DataSet: TDataSet);
var
i: integer;
begin
SetLength(LastValues, DataSet.FieldCount);
for i:=0 to DataSet.FieldCount-1 do
begin
LastValues[i].FieldName := DataSet.Fields.Fields[i].FieldName;
LastValues[i].FieldValue := DataSet.Fields.Fields[i].OldValue;
end;
end;
function TMyDataSource.GetLastValue(FieldName: string): Variant;
var
i: integer;
begin
Result := Null;
for i:=0 to Length(LastValues)-1 do
if SameText(FieldName, LastValues[i].FieldName) then
begin
Result := LastValues[i].FieldValue;
break;
end;
end;
and after override application Data Source
TForm1 = class(TForm)
private
MyDataSource: TMyDataSource;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
ADOQuery1.Active := true;
MyDataSource := TMyDataSource.Create(Self);
MyDataSource.MyDataSet := ADOQuery1;
DBGrid1.DataSource := MyDataSource;
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
MyDataSource.Free;
end;
procedure TForm1.ADOQuery1AfterPost(DataSet: TDataSet);
var
AValue: Variant;
begin
AValue := MyDataSource.GetLastValue('cname');
if not VarIsNull(AValue) then;
end;
I want to write a program that works on a hierarchically organized tree data structure.
I need to have a root node and then be able to add child nodes and to move these node across the complete tree.
Is there a data structure in Delphi I can use for my algorithms and then later simply "copy" it to the GUI using a TTreeview component?
I suppose I need such a class:
type
TMyElement = class(...)
ElementName: String;
...
ChildElementList: TMyElementList;
HasChildElement: Boolean;
...
end;
At the dots, there will be more fields and routines specific for the element. How to build up this class? And how can I conveniently add these elements to a TreeView, using the ElementName field as caption for the tree nodes?
So, you have two questions:
How to build up this class?
Well, not yet focusing on the viewing-in-a-tree-view-ability, you could descent your class from TObjectList. Doing so, every element is capable of holding more of these object lists = elements. This approach is for example used for TMenuItem too.
And how can I conveniently add these elements to a TreeView, using the ElementName field as caption for the tree nodes?
You could add an AssignTo method to the class so that you can "assign" the root node to the TreeView.
Here you have an example implementation of the whole class. Add own properties as needed.
type
TElement = class(TObjectList)
private
FName: String;
FParent: TElement;
function GetItem(Index: Integer): TElement;
function GetLevel: Integer;
procedure SetItem(Index: Integer; Value: TElement);
protected
procedure Notify(Ptr: Pointer; Action: TListNotification); override;
public
function Add(AElement: TElement): Integer;
procedure AssignTo(Dest: TPersistent);
constructor Create; overload;
constructor Create(AName: String); overload;
constructor Create(AParent: TElement); overload;
constructor Create(AParent: TElement; AName: String); overload;
destructor Destroy; override;
function HasChilds: Boolean;
procedure Insert(Index: Integer; AElement: TObject);
property Items[Index: Integer]: TElement read GetItem write SetItem;
default;
property Level: Integer read GetLevel;
property Name: String read FName write FName;
end;
{ TElement }
function TElement.Add(AElement: TElement): Integer;
begin
if AElement = nil then
Result := -1
else
Result := inherited Add(AElement);
end;
procedure TElement.AssignTo(Dest: TPersistent);
var
Nodes: TTreeNodes;
Node: TTreeNode;
I: Integer;
begin
if Dest is TTreeView then
AssignTo(TTreeView(Dest).Items)
else if Dest is TTreeNodes then
begin
Nodes := TTreeNodes(Dest);
Nodes.BeginUpdate;
Nodes.Clear;
for I := 0 to Count - 1 do
begin
Node := Nodes.AddNode(nil, nil, Items[I].Name, Items[I], naAdd);
Items[I].AssignTo(Node);
end;
Nodes.EndUpdate;
end
else if Dest is TTreeNode then
begin
Node := TTreeNode(Dest);
Nodes := Node.Owner;
for I := 0 to Count - 1 do
Items[I].AssignTo(
Nodes.AddNode(nil, Node, Items[I].Name, Items[I], naAddChild));
end;
end;
constructor TElement.Create;
begin
Create(nil, '');
end;
constructor TElement.Create(AName: String);
begin
Create(nil, AName);
end;
constructor TElement.Create(AParent: TElement);
begin
Create(AParent, '');
end;
constructor TElement.Create(AParent: TElement; AName: String);
begin
inherited Create(True);
FName := AName;
if AParent <> nil then
AParent.Add(Self);
end;
destructor TElement.Destroy;
begin
if FParent <> nil then
FParent.Extract(Self);
inherited Destroy;
end;
function TElement.GetItem(Index: Integer): TElement;
begin
Result := TElement(inherited Items[Index]);
end;
function TElement.GetLevel: Integer;
begin
if FParent = nil then
Result := 0
else
Result := FParent.Level + 1;
end;
function TElement.HasChilds: Boolean;
begin
Result := Count > 0;
end;
procedure TElement.Insert(Index: Integer; AElement: TObject);
begin
if AElement <> nil then
inherited Insert(Index, AElement);
end;
procedure TElement.Notify(Ptr: Pointer; Action: TListNotification);
begin
inherited Notify(Ptr, Action);
case Action of
lnAdded:
TElement(Ptr).FParent := Self;
lnExtracted,
lnDeleted:
TElement(Ptr).FParent := nil;
end;
end;
procedure TElement.SetItem(Index: Integer; Value: TElement);
begin
inherited Items[Index] := Value;
end;
Example usage:
procedure TForm2.FormCreate(Sender: TObject);
begin
FRoot := TElement.Create;
TElement.Create(FRoot, '1');
TElement.Create(FRoot, '2');
TElement.Create(FRoot[1], '2.1');
TElement.Create(FRoot[1], '2.2');
TElement.Create(FRoot[1][0], '2.1.1');
TElement.Create(FRoot[1][0][0], '2.1.1.1');
TElement.Create(FRoot[1][0][0], '2.1.1.2');
TElement.Create(FRoot[1], '2.3');
TElement.Create(FRoot, '3');
TElement.Create(FRoot, '4');
TElement.Create(FRoot[3], '4.1');
FRoot.AssignTo(TreeView1);
end;
Filling a TTreeView at runtime is great fun!
Google 'rmtreenonview'. It is a single unit which implements a non-visual TTreeView-like class--most of the methods and properties are fully compatible with TTreeView.
rmtreenonview is quick and lightweight...we use it for manipulating a bunch of tree-structured data, but write the results to a grid control for display. But, you could copy results to a TTReeView just as easily.
Oh, and it also has hash-based tree searching capability and a couple other additons.
What do I need to do for adding actions support to my component. It is a button component but I guess it is the same for whatever component type it is. Any information or how to will help.
That depends on how you define action support. There is two kinds:
A possibly customized Action property of your component, which is assignable by an Action component
The Action component itself.
An action property
Every TControl descendant has an Action property which execution is by default linked to a left mouse button click. This link is managed by an ActionLink. The default ActionLink is of the type TControlActionLink which takes care of the synchronization of the caption, the hint, the enabled state, etc... of both the Action and that of the Control. If this basis functionality is all that you want, then simply publish the Action property in your component type declaration and the Delphi framework takes care of all, like Serg and LU RD already answered.
If you want your own Action property to be linked to some other condition or event (i.e. other than Click), or if you want to implement an Action property for a specific sub element of your component (that is not a TControl descendant), then you can implement your own custom Action property by defining and implementing a custom ActionLink class.
Suppose your component is some kind of grid which has columns and you want every column to have an action property that should be invoked when the user clicks the title of a column. Since such columns are likely to be of a TCollectionItem type, the column type does not have an action property by default. So you have to implement one yourself. Consider the next example which links the action's caption to the column's title, links the action's enabled state inversely to the column's readonly property and so on...:
unit Unit1;
interface
uses
Classes, ActnList, SysUtils;
type
TColumn = class;
TColumnActionLink = class(TActionLink)
protected
FClient: TColumn;
procedure AssignClient(AClient: TObject); override;
function IsCaptionLinked: Boolean; override;
function IsEnabledLinked: Boolean; override;
function IsOnExecuteLinked: Boolean; override;
function IsVisibleLinked: Boolean; override;
procedure SetCaption(const Value: String); override;
procedure SetEnabled(Value: Boolean); override;
procedure SetOnExecute(Value: TNotifyEvent); override;
procedure SetVisible(Value: Boolean); override;
end;
TColumnActionLinkClass = class of TColumnActionLink;
TColumn = class(TCollectionItem)
private
FActionLink: TColumnActionLink;
FGrid: TComponent;
FOnTitleClick: TNotifyEvent;
FReadOnly: Boolean;
FTitle: String;
FVisible: Boolean;
function DefaultTitleCaption: String;
procedure DoActionChange(Sender: TObject);
function GetAction: TBasicAction;
function IsOnTitleClickStored: Boolean;
function IsReadOnlyStored: Boolean;
function IsVisibleStored: Boolean;
procedure SetAction(Value: TBasicAction);
protected
procedure ActionChanged(Sender: TObject; CheckDefaults: Boolean); dynamic;
procedure DoTitleClick; virtual;
function GetActionLinkClass: TColumnActionLinkClass; virtual;
property ActionLink: TColumnActionLink read FActionLink write FActionLink;
public
destructor Destroy; override;
procedure InitiateAction; virtual;
published
property Action: TBasicAction read GetAction write SetAction;
property OnTitleClick: TNotifyEvent read FOnTitleClick write FOnTitleClick
stored IsOnTitleClickStored;
property ReadOnly: Boolean read FReadOnly write FReadOnly
stored IsReadOnlyStored;
property Title: String read FTitle write FTitle;
property Visible: Boolean read FVisible write FVisible
stored IsVisibleStored;
end;
implementation
{ TColumnActionLink }
procedure TColumnActionLink.AssignClient(AClient: TObject);
begin
FClient := TColumn(AClient);
end;
function TColumnActionLink.IsCaptionLinked: Boolean;
begin
Result := inherited IsCaptionLinked and (Action is TCustomAction) and
(FClient.Title = TCustomAction(Action).Caption);
end;
function TColumnActionLink.IsEnabledLinked: Boolean;
begin
Result := inherited IsEnabledLinked and (Action is TCustomAction) and
(FClient.ReadOnly <> TCustomAction(Action).Enabled);
end;
function TColumnActionLink.IsOnExecuteLinked: Boolean;
begin
Result := inherited IsOnExecuteLinked and
(#FClient.OnTitleClick = #Action.OnExecute);
end;
function TColumnActionLink.IsVisibleLinked: Boolean;
begin
Result := inherited IsVisibleLinked and (Action is TCustomAction) and
(FClient.Visible = TCustomAction(Action).Visible);
end;
procedure TColumnActionLink.SetCaption(const Value: string);
begin
if IsCaptionLinked then
FClient.Title := Value;
end;
procedure TColumnActionLink.SetEnabled(Value: Boolean);
begin
if IsEnabledLinked then
FClient.ReadOnly := not Value;
end;
procedure TColumnActionLink.SetOnExecute(Value: TNotifyEvent);
begin
if IsOnExecuteLinked then
FClient.OnTitleClick := Value;
end;
procedure TColumnActionLink.SetVisible(Value: Boolean);
begin
if IsVisibleLinked then
FClient.Visible := Value;
end;
{ TColumn }
procedure TColumn.ActionChanged(Sender: TObject; CheckDefaults: Boolean);
begin
if Sender is TCustomAction then
with TCustomAction(Sender) do
begin
if not CheckDefaults or (Caption = DefaultTitleCaption) then
FTitle := Caption;
if not CheckDefaults or (not ReadOnly) then
ReadOnly := not Enabled;
if not CheckDefaults or not Assigned(FOnTitleClick) then
FOnTitleClick := OnExecute;
if not CheckDefaults or (Self.Visible = True) then
Self.Visible := Visible;
Changed(False);
end;
end;
function TColumn.DefaultTitleCaption: String;
begin
Result := 'Column' + IntToStr(Index);
end;
destructor TColumn.Destroy;
begin
FreeAndNil(FActionLink);
inherited Destroy;
end;
procedure TColumn.DoActionChange(Sender: TObject);
begin
if Sender = Action then
ActionChanged(Sender, False);
end;
procedure TColumn.DoTitleClick;
begin
if Assigned(FOnTitleClick) then
if (Action <> nil) and (#FOnTitleClick <> #Action.OnExecute) then
FOnTitleClick(Self)
else if FActionLink = nil then
FOnTitleClick(Self)
else if FActionLink <> nil then
if (FGrid <> nil) and not (csDesigning in FGrid.ComponentState) then
begin
if not FActionLink.Execute(FGrid) then
FOnTitleClick(Self);
end
else
if not FActionLink.Execute(nil) then
FOnTitleClick(Self);
end;
function TColumn.GetAction: TBasicAction;
begin
if FActionLink <> nil then
Result := FActionLink.Action
else
Result := nil;
end;
function TColumn.GetActionLinkClass: TColumnActionLinkClass;
begin
Result := TColumnActionLink;
end;
procedure TColumn.InitiateAction;
begin
if FActionLink <> nil then
FActionLink.Update;
end;
function TColumn.IsOnTitleClickStored: Boolean;
begin
Result := (FActionLink = nil) or not ActionLink.IsOnExecuteLinked;
end;
function TColumn.IsReadOnlyStored: Boolean;
begin
Result := (FActionLink = nil) or not FActionLink.IsEnabledLinked;
if Result then
Result := FReadOnly;
end;
function TColumn.IsVisibleStored: Boolean;
begin
Result := (FActionLink = nil) or not FActionLink.IsVisibleLinked;
if Result then
Result := not Visible;
end;
procedure TColumn.SetAction(Value: TBasicAction);
begin
if Value = nil then
FreeAndNil(FActionLink)
else
begin
if FActionLink = nil then
FActionLink := GetActionLinkClass.Create(Self);
FActionLink.Action := Value;
FActionLink.OnChange := DoActionChange;
ActionChanged(Value, csLoading in Value.ComponentState);
if FGrid <> nil then
Value.FreeNotification(FGrid);
end;
Changed(False);
end;
end.
Note that this code is stripped to only the applicable action parts.
Source: www.nldelphi.com.
An action component
An action component is assignable to the action property of an arbitrary component. But since explaining all that is involved with writing such an action component is pretty comprehensive, I will make it easy for myself in providing the example below.
Suppose you want to make a control that provides zoom capabilities and that you also want the corresponding ZoomIn and ZoomOut actions that can be assigned to toolbar buttons.
unit Zoomer;
interface
uses
Classes, Controls, ActnList, Forms, Menus, Windows;
type
TZoomer = class;
TZoomAction = class(TCustomAction)
private
FZoomer: TZoomer;
procedure SetZoomer(Value: TZoomer);
protected
function GetZoomer(Target: TObject): TZoomer;
procedure Notification(AComponent: TComponent; Operation: TOperation);
override;
public
destructor Destroy; override;
function HandlesTarget(Target: TObject): Boolean; override;
procedure UpdateTarget(Target: TObject); override;
published
property Caption;
property Enabled;
property HelpContext;
property HelpKeyword;
property HelpType;
property Hint;
property ImageIndex;
property ShortCut;
property SecondaryShortCuts;
property Visible;
property OnExecute; { This property could be omitted. But if you want to be
able to override the default behavior of this action
(zooming in on a TZoomer component), then you need to
assign this event. From within the event handler
you could invoke the default behavior manually. }
property OnHint;
property OnUpdate;
property Zoomer: TZoomer read FZoomer write SetZoomer;
end;
TZoomInAction = class(TZoomAction)
public
constructor Create(AOwner: TComponent); override;
procedure ExecuteTarget(Target: TObject); override;
end;
TZoomer = class(TCustomControl)
public
procedure ZoomIn;
end;
procedure Register;
implementation
procedure Register;
begin
RegisterComponents('RoyMKlever', [TZoomer]);
RegisterActions('Zoomer', [TZoomInAction], nil);
end;
{ TZoomAction }
destructor TZoomAction.Destroy;
begin
if FZoomer <> nil then
FZoomer.RemoveFreeNotification(Self);
inherited Destroy;
end;
function TZoomAction.GetZoomer(Target: TObject): TZoomer;
begin
if FZoomer <> nil then
Result := FZoomer
else if (Target is TZoomer) and TZoomer(Target).Focused then
Result := TZoomer(Target)
else if Screen.ActiveControl is TZoomer then
Result := TZoomer(Screen.ActiveControl)
else
{ This should not happen! HandlesTarget is called before ExecuteTarget,
or the action is disabled }
Result := nil;
end;
function TZoomAction.HandlesTarget(Target: TObject): Boolean;
begin
Result := ((FZoomer <> nil) and FZoomer.Enabled) or
((FZoomer = nil) and (Target is TZoomer) and TZoomer(Target).Focused) or
((Screen.ActiveControl is TZoomer) and Screen.ActiveControl.Enabled);
end;
procedure TZoomAction.Notification(AComponent: TComponent;
Operation: TOperation);
begin
inherited Notification(AComponent, Operation);
if (Operation = opRemove) and (AComponent = FZoomer) then
FZoomer := nil;
end;
procedure TZoomAction.SetZoomer(Value: TZoomer);
begin
if FZoomer <> Value then
begin
if FZoomer <> nil then
FZoomer.RemoveFreeNotification(Self);
FZoomer := Value;
if FZoomer <> nil then
FZoomer.FreeNotification(Self);
end;
end;
procedure TZoomAction.UpdateTarget(Target: TObject);
begin
Enabled := HandlesTarget(Target);
end;
{ TZoomInAction }
constructor TZoomInAction.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
Caption := 'Zoom in';
Hint := 'Zoom in|Zooms in on the selected zoomer control';
ShortCut := Menus.ShortCut(VK_ADD, [ssCtrl]);
end;
procedure TZoomInAction.ExecuteTarget(Target: TObject);
begin
GetZoomer(Target).ZoomIn;
{ For safety, you cóuld check if GetZoomer <> nil. See remark in GetZoomer. }
end;
{ TZoomer }
procedure TZoomer.ZoomIn;
begin
{ implementation of zooming in }
end;
end.
Activating this action (with a click on a toolbar button, or choosing a menu item) calls in the following priority the ZoomIn routine of:
the Zoomer control that you manually have set in the relating property of the action, if done so, and if the action is enabled, otherwise:
the by the application requested Target, but only if that target is a focused Zoomer control, or otherwise:
the active control in the entire application, but only if that is an enabled Zoomer control.
Subsequently, the ZoomOut action is simply added:
type
TZoomOutAction = class(TZoomAction)
public
constructor Create(AOwner: TComponent); override;
procedure ExecuteTarget(Target: TObject); override;
end;
{ TZoomOutAction }
constructor TZoomOutAction.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
Caption := 'Zoom out';
Hint := 'Zoom out|Zooms out on the selected zoomer control';
ShortCut := Menus.ShortCut(VK_SUBTRACT, [ssCtrl]);
end;
procedure TZoomOutAction.ExecuteTarget(Target: TObject);
begin
GetZoomer(Target).ZoomOut;
end;
Note that action components require registration in the IDE for being able to use them design time.
Applicable read food in the Delphi help:
Writing action components,
How actions find their targets,
Registering actions,
What happens when an action fires,
Updating actions,
Setting up action lists.
Source: www.nldelphi.com.
Basic action support is implemented in TControl class, so in the most simple case all you have to do is to inherit your component from TControl descendant and declare Action property as published, ex:
type
TMyGraphicControl = class(TGraphicControl)
published
property Action;
end;
If your component has additional properties that should be linked to TAction properties you should also override ActionChange method.
If your component is already a descendant of TButton then the action support is inherited.
All you need to do is declare the action property as published.