1 {
2  /***************************************************************************
3                                    ActnList.pas
4                                    ------------
5 
6 
7  ***************************************************************************/
8 
9  *****************************************************************************
10   This file is part of the Lazarus Component Library (LCL)
11 
12   See the file COPYING.modifiedLGPL.txt, included in this distribution,
13   for details about the license.
14  *****************************************************************************
15 }
16 unit ActnList;
17 
18 {$mode objfpc}{$H+}
19 
20 interface
21 
22 uses
23   Classes, SysUtils,
24   LCLStrConsts, LCLType, LCLProc, LCLIntf, ImgList, LCLClasses, LMessages;
25 
26 type
27 
28   { TContainedAction }
29 
30   TCustomActionList = class;
31 
32   TContainedAction = class(TBasicAction)
33   private
34     FCategory: string;
35     FActionList: TCustomActionList;
GetIndexnull36     function GetIndex: Integer;
37     procedure SetCategory(const Value: string);
38     procedure SetIndex(Value: Integer);
39     procedure SetActionList(NewActionList: TCustomActionList);
40   protected
41     procedure ReadState(Reader: TReader); override;
42     procedure SetParentComponent(AParent: TComponent); override;
43   public
44     destructor Destroy; override;
Executenull45     function Execute: Boolean; override;
GetParentComponentnull46     function GetParentComponent: TComponent; override;
HasParentnull47     function HasParent: Boolean; override;
Updatenull48     function Update: Boolean; override;
49     property ActionList: TCustomActionList read FActionList write SetActionList;
50     property Index: Integer read GetIndex write SetIndex stored False;
51   published
52     property Category: string read FCategory write SetCategory;
53   end;
54 
55   TContainedActionClass = class of TContainedAction;
56 
57   { TActionListEnumerator }
58 
59   TActionListEnumerator = class
60   private
61     FList: TCustomActionList;
62     FPosition: Integer;
GetCurrentnull63     function GetCurrent: TContainedAction;
64   public
65     constructor Create(AList: TCustomActionList);
MoveNextnull66     function MoveNext: Boolean;
67     property Current: TContainedAction read GetCurrent;
68   end;
69 
70 
71   { TCustomActionList }
72 
73   TActionEvent = procedure (AAction: TBasicAction; var Handled: Boolean) of object;
74   TActionListState = (asNormal, asSuspended, asSuspendedEnabled);
75 
76   TCustomActionList = class(TLCLComponent)
77   private
78     FActions: TFPList;// list of TContainedAction
79     FImageChangeLink: TChangeLink;
80     FImages: TCustomImageList;
81     FOnChange: TNotifyEvent;
82     FOnExecute: TActionEvent;
83     FOnUpdate: TActionEvent;
84     FState: TActionListState;
GetActionnull85     function GetAction(Index: Integer): TContainedAction;
GetActionCountnull86     function GetActionCount: Integer;
87     procedure ImageListChange(Sender: TObject);
88     procedure SetAction(Index: Integer; Value: TContainedAction);
89     procedure SetState(const Value: TActionListState);
90   protected
91     procedure AddAction(Action: TContainedAction); virtual;
92     procedure RemoveAction(Action: TContainedAction); virtual;
93     procedure Change; virtual;
94     procedure GetChildren(Proc: TGetChildProc; Root: TComponent); override;
95     procedure Notification(AComponent: TComponent;
96       Operation: TOperation); override;
97     procedure SetChildOrder(Component: TComponent; Order: Integer); override;
98     procedure SetImages(Value: TCustomImageList); virtual;
99     property OnChange: TNotifyEvent read FOnChange write FOnChange;
100     property OnExecute: TActionEvent read FOnExecute write FOnExecute;
101     property OnUpdate: TActionEvent read FOnUpdate write FOnUpdate;
102   public
103     constructor Create(AOwner: TComponent); override;
104     destructor Destroy; override;
105 
ActionByNamenull106     function ActionByName(const ActionName: string): TContainedAction;
ExecuteActionnull107     function ExecuteAction(Action: TBasicAction): Boolean; override;
GetEnumeratornull108     function GetEnumerator: TActionListEnumerator;
IndexOfNamenull109     function IndexOfName(const ActionName: string): integer;
IsShortCutnull110     function IsShortCut(var Message: TLMKey): Boolean;
UpdateActionnull111     function UpdateAction(Action: TBasicAction): Boolean; override;
112 
113     property Actions[Index: Integer]: TContainedAction read GetAction write SetAction; default;
114     property ActionCount: Integer read GetActionCount;
115     property Images: TCustomImageList read FImages write SetImages;
116     property State: TActionListState read FState write SetState default asNormal;
117   end;
118 
119 
120   { TActionList }
121 
122   TActionList = class(TCustomActionList)
123   published
124     property Images;
125     property State;
126     property OnChange;
127     property OnExecute;
128     property OnUpdate;
129   end;
130 
131 
132   { TShortCutList
133     List of shortcut and texts. The TShortCut values are stored in the Objects. }
134 
135   TShortCutList = class(TStringList)
136   private
GetShortCutsnull137     function GetShortCuts(Index: Integer): TShortCut;
138   public
Addnull139     function Add(const S: String): Integer; override;
IndexOfShortCutnull140     function IndexOfShortCut(const Shortcut: TShortCut): Integer;
141     property ShortCuts[Index: Integer]: TShortCut read GetShortCuts;
142   end;
143 
144 
145   { TCustomAction
146     FClients is a list of TActionLink }
147 
148   THintEvent = procedure (var HintStr: string; var CanShow: Boolean) of object;
149 
150   TCustomAction = class(TContainedAction)
151   private
152     FAutoCheck: Boolean;
153     FCaption: TTranslateString;
154     FChecked: Boolean;
155     FChecking: Boolean;
156     FDisableIfNoHandler: Boolean;
157     FEnabled: Boolean;
158     FGroupIndex: Integer;
159     FHelpContext: THelpContext;
160     FHelpKeyword: string;
161     FHelpType: THelpType;
162     FHint: TTranslateString;
163     FImageIndex: TImageIndex;
164     FOnHint: THintEvent;
165     FSavedEnabledState: Boolean;
166     FSecondaryShortCuts: TShortCutList;// nil as default
167     FShortCut: TShortCut;
168     FVisible: Boolean;
169     procedure SetAutoCheck(Value: Boolean);
170     procedure SetCaption(const Value: TTranslateString);
171     procedure SetChecked(Value: Boolean);
172     procedure SetEnabled(Value: Boolean);
173     procedure SetGroupIndex(const Value: Integer);
174     procedure SetHelpContext(Value: THelpContext); virtual;
175     procedure SetHelpKeyword(const Value: string); virtual;
176     procedure SetHelpType(Value: THelpType);
177     procedure SetHint(const Value: TTranslateString);
178     procedure SetImageIndex(Value: TImageIndex);
179     procedure SetShortCut(Value: TShortCut);
180     procedure SetVisible(Value: Boolean);
GetSecondaryShortCutsnull181     function GetSecondaryShortCuts: TShortCutList;
182     procedure SetSecondaryShortCuts(const Value: TShortCutList);
IsSecondaryShortCutsStorednull183     function IsSecondaryShortCutsStored: Boolean;
184   protected
185     FImage: TObject;
186     FMask: TObject;
187     procedure AssignTo(Dest: TPersistent); override;
188     procedure SetName(const Value: TComponentName); override;
HandleShortCutnull189     function HandleShortCut: Boolean; virtual;
190     property SavedEnabledState: Boolean
191       read FSavedEnabledState write FSavedEnabledState;
192   public
193     constructor Create(AOwner: TComponent); override;
194     destructor Destroy; override;
DoHintnull195     function DoHint(var HintStr: string): Boolean; virtual;
Executenull196     function Execute: Boolean; override;
197   public
198     property AutoCheck: Boolean
199                               read FAutoCheck write  SetAutoCheck default False;
200     property Caption: TTranslateString read FCaption write SetCaption;
201     property Checked: Boolean read FChecked write SetChecked default False;
202     property DisableIfNoHandler: Boolean read FDisableIfNoHandler
203                                         write FDisableIfNoHandler default False;
204     property Enabled: Boolean read FEnabled write SetEnabled default True;
205     property GroupIndex: Integer read FGroupIndex write SetGroupIndex default 0;
206     property HelpContext: THelpContext
207                                read FHelpContext write SetHelpContext default 0;
208     property HelpKeyword: string read FHelpKeyword write SetHelpKeyword;
209     property HelpType: THelpType
210                              read FHelpType write SetHelpType default htContext;
211     property Hint: TTranslateString read FHint write SetHint;
212     property ImageIndex: TImageIndex
213                                 read FImageIndex write SetImageIndex default -1;
214     property OnHint: THintEvent read FOnHint write FOnHint;
215     property SecondaryShortCuts: TShortCutList read GetSecondaryShortCuts
216                   write SetSecondaryShortCuts stored IsSecondaryShortCutsStored;
217     property ShortCut: TShortCut read FShortCut write SetShortCut default 0;
218     property Visible: Boolean read FVisible write SetVisible default True;
219   end;
220 
221 
222   { TAction }
223 
224   TAction = class(TCustomAction)
225   public
226     constructor Create(AOwner: TComponent); override;
227   published
228     property AutoCheck;
229     property Caption;
230     property Checked;
231     property DisableIfNoHandler default True;
232     property Enabled;
233     property GroupIndex;
234     property HelpContext;
235     property HelpKeyword;
236     property HelpType;
237     property Hint;
238     property ImageIndex;
239     property OnExecute;
240     property OnHint;
241     property OnUpdate;
242     property SecondaryShortCuts;
243     property ShortCut;
244     property Visible;
245   end;
246 
247 
248   { TActionLink }
249 
250   TActionLink = class(TBasicActionLink)
251   protected
252     procedure SetAutoCheck(Value: Boolean); virtual;
253     procedure SetCaption(const Value: string); virtual;
254     procedure SetChecked(Value: Boolean); virtual;
255     procedure SetEnabled(Value: Boolean); virtual;
256     procedure SetGroupIndex(Value: Integer); virtual;
257     procedure SetHelpContext(Value: THelpContext); virtual;
258     procedure SetHelpKeyword(const Value: string); virtual;
259     procedure SetHelpType(Value: THelpType); virtual;
260     procedure SetHint(const Value: string); virtual;
261     procedure SetImageIndex(Value: Integer); virtual;
262     procedure SetShortCut(Value: TShortCut); virtual;
263     procedure SetVisible(Value: Boolean); virtual;
264   public
IsCaptionLinkednull265     function IsCaptionLinked: Boolean; virtual;
IsCheckedLinkednull266     function IsCheckedLinked: Boolean; virtual;
IsEnabledLinkednull267     function IsEnabledLinked: Boolean; virtual;
IsGroupIndexLinkednull268     function IsGroupIndexLinked: Boolean; virtual;
IsHelpContextLinkednull269     function IsHelpContextLinked: Boolean; virtual;
IsHelpLinkednull270     function IsHelpLinked: Boolean; virtual;
IsHintLinkednull271     function IsHintLinked: Boolean; virtual;
IsImageIndexLinkednull272     function IsImageIndexLinked: Boolean; virtual;
IsShortCutLinkednull273     function IsShortCutLinked: Boolean; virtual;
IsVisibleLinkednull274     function IsVisibleLinked: Boolean; virtual;
275   end;
276 
277   TActionLinkClass = class of TActionLink;
278 
279 
280 type
281   TEnumActionProc = procedure (const Category: string;
282     ActionClass: TBasicActionClass; Info: Pointer) of object;
283 
284 procedure RegisterActions(const CategoryName: string;
285   const AClasses: array of TBasicActionClass; Resource: TComponentClass);
286 procedure UnRegisterActions(const AClasses: array of TBasicActionClass);
287 procedure EnumRegisteredActions(Proc: TEnumActionProc; Info: Pointer);
CreateActionnull288 function CreateAction(TheOwner: TComponent;
289   ActionClass: TBasicActionClass): TBasicAction;
290 
291 const
292   RegisterActionsProc: procedure (const CategoryName: string;
293                                   const AClasses: array of TBasicActionClass;
294                                   Resource: TComponentClass)= nil;
295   UnRegisterActionsProc: procedure(const AClasses: array of TBasicActionClass
296                                    ) = nil;
297   EnumRegisteredActionsProc: procedure(Proc: TEnumActionProc;
298                                        Info: Pointer) = nil;
heOwnernull299   CreateActionProc: function(TheOwner: TComponent;
300                             ActionClass: TBasicActionClass): TBasicAction = nil;
301 
302 var
303   ApplicationActionComponent: TComponent = nil;
304 
305 
306 procedure Register;
307 
308 implementation
309 
310 procedure RegisterActions(const CategoryName: string;
311   const AClasses: array of TBasicActionClass; Resource: TComponentClass);
312 begin
313   if Assigned(RegisterActionsProc) then
314     RegisterActionsProc(CategoryName, AClasses, Resource)
315   else
316     raise Exception.Create(SInvalidActionRegistration);
317 end;
318 
319 procedure UnRegisterActions(const AClasses: array of TBasicActionClass);
320 begin
321   if Assigned(UnRegisterActionsProc) then
322     UnRegisterActionsProc(AClasses)
323   else
324     raise Exception.Create(SInvalidActionUnregistration);
325 end;
326 
327 procedure EnumRegisteredActions(Proc: TEnumActionProc; Info: Pointer);
328 begin
329   if Assigned(EnumRegisteredActionsProc) then
330     EnumRegisteredActionsProc(Proc, Info)
331   else
332     raise Exception.Create(SInvalidActionEnumeration);
333 end;
334 
CreateActionnull335 function CreateAction(TheOwner: TComponent;
336   ActionClass: TBasicActionClass): TBasicAction;
337 begin
338   if Assigned(CreateActionProc) then
339     Result := CreateActionProc(TheOwner, ActionClass)
340   else
341     raise Exception.Create(SInvalidActionCreation);
342 end;
343 
344 {$I containedaction.inc}
345 {$I customactionlist.inc}
346 {$I actionlink.inc}
347 {$I shortcutlist.inc}
348 {$I customaction.inc}
349 {$I lclaction.inc}
350 
351 { TActionListEnumerator }
352 
TActionListEnumerator.GetCurrentnull353 function TActionListEnumerator.GetCurrent: TContainedAction;
354 begin
355   Result := FList.Actions[FPosition];
356 end;
357 
358 constructor TActionListEnumerator.Create(AList: TCustomActionList);
359 begin
360   inherited Create;
361   FList := AList;
362   FPosition := -1;
363 end;
364 
MoveNextnull365 function TActionListEnumerator.MoveNext: Boolean;
366 begin
367   inc(FPosition);
368   Result := FPosition < FList.ActionCount;
369 end;
370 
371 procedure Register;
372 begin
373   RegisterComponents('Standard',[TActionList]);
374   RegisterNoIcon([TAction]);
375 end;
376 
377 initialization
378   ApplicationActionComponent:=nil;
379 
380 end.
381