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