MG: added actnlist.pp

git-svn-id: trunk@1824 -

.gitattributes

@@ -417,6 +417,7 @@ images/uparrow.ico -text svneol=unset#image/x-icon
 images/uparrow.xpm -text svneol=native#image/x-xpixmap
 languages/lazaruside.de.po svneol=native#text/plain
 languages/lazaruside.po svneol=native#text/plain
+lcl/actnlist.pas svneol=native#text/pascal
 lcl/allunits.pp svneol=native#text/pascal
 lcl/arrow.pp svneol=native#text/pascal
 lcl/buttons.pp svneol=native#text/pascal
@@ -435,6 +436,8 @@ lcl/graphics.pp svneol=native#text/pascal
 lcl/graphicsmath.pp svneol=native#text/pascal
 lcl/graphtype.pp svneol=native#text/pascal
 lcl/imglist.pp svneol=native#text/pascal
+lcl/include/action.inc svneol=native#text/pascal
+lcl/include/actionlink.inc svneol=native#text/pascal
 lcl/include/alignment.inc svneol=native#text/pascal
 lcl/include/application.inc svneol=native#text/pascal
 lcl/include/basedragcontrolobject.inc svneol=native#text/pascal
@@ -452,9 +455,11 @@ lcl/include/checkbox.inc svneol=native#text/pascal
 lcl/include/clipbrd.inc svneol=native#text/pascal
 lcl/include/colordialog.inc svneol=native#text/pascal
 lcl/include/commondialog.inc svneol=native#text/pascal
+lcl/include/containedaction.inc svneol=native#text/pascal
 lcl/include/control.inc svneol=native#text/pascal
 lcl/include/controlcanvas.inc svneol=native#text/pascal
 lcl/include/controlsproc.inc svneol=native#text/pascal
+lcl/include/customaction.inc svneol=native#text/pascal
 lcl/include/customcheckbox.inc svneol=native#text/pascal
 lcl/include/customcombobox.inc svneol=native#text/pascal
 lcl/include/customcontrol.inc svneol=native#text/pascal
@@ -493,6 +498,7 @@ lcl/include/mainmenu.inc svneol=native#text/pascal
 lcl/include/memo.inc svneol=native#text/pascal
 lcl/include/memostrings.inc svneol=native#text/pascal
 lcl/include/menu.inc svneol=native#text/pascal
+lcl/include/menuactionlink.inc svneol=native#text/pascal
 lcl/include/menubar.inc svneol=native#text/pascal
 lcl/include/menuitem.inc svneol=native#text/pascal
 lcl/include/messagedialogpixmaps.inc svneol=native#text/pascal
@@ -515,6 +521,7 @@ lcl/include/screen.inc svneol=native#text/pascal
 lcl/include/scrollbar.inc svneol=native#text/pascal
 lcl/include/scrolledwindow.inc svneol=native#text/pascal
 lcl/include/sharedimage.inc svneol=native#text/pascal
+lcl/include/shortcutlist.inc svneol=native#text/pascal
 lcl/include/sizeconstraints.inc svneol=native#text/pascal
 lcl/include/speedbutton.inc svneol=native#text/pascal
 lcl/include/spinedit.inc svneol=native#text/pascal

lcl/actnlist.pas

@@ -0,0 +1,340 @@
+{
+ /***************************************************************************
+                                   ActnList.pas
+                                   ------------
+
+
+ ***************************************************************************/
+
+ *****************************************************************************
+ *                                                                           *
+ *  This file is part of the Lazarus Component Library (LCL)                 *
+ *                                                                           *
+ *  See the file COPYING.LCL, included in this distribution,                 *
+ *  for details about the copyright.                                         *
+ *                                                                           *
+ *  This program is distributed in the hope that it will be useful,          *
+ *  but WITHOUT ANY WARRANTY; without even the implied warranty of           *
+ *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.                     *
+ *                                                                           *
+ *****************************************************************************
+}
+unit ActnList;
+
+{$mode objfpc}{$H+}
+
+interface
+
+uses
+  Classes, SysUtils, ImgList;
+  
+type
+
+  { TContainedAction }
+
+  TCustomActionList = class;
+
+  TContainedAction = class(TBasicAction)
+  private
+    FCategory: string;
+    FActionList: TCustomActionList;
+    function GetIndex: Integer;
+    function IsCategoryStored: Boolean;
+    procedure SetCategory(const Value: string);
+    procedure SetIndex(Value: Integer);
+    procedure SetActionList(AActionList: TCustomActionList);
+  protected
+    procedure ReadState(Reader: TReader); override;
+    procedure SetParentComponent(AParent: TComponent); override;
+    procedure Change; override;
+  public
+    destructor Destroy; override;
+    function Execute: Boolean; override;
+    function GetParentComponent: TComponent; override;
+    function HasParent: Boolean; override;
+    function Update: Boolean; override;
+    property ActionList: TCustomActionList read FActionList write SetActionList;
+    property Index: Integer read GetIndex write SetIndex stored False;
+  published
+    property Category: string
+      read FCategory write SetCategory stored IsCategoryStored;
+  end;
+
+  TContainedActionClass = class of TContainedAction;
+
+
+  { TCustomActionList }
+
+  TActionEvent = procedure (Action: TBasicAction; var Handled: Boolean) of object;
+  TActionListState = (asNormal, asSuspended, asSuspendedEnabled);
+
+  TCustomActionList = class(TComponent)
+  private
+    FActions: TList;
+    FImageChangeLink: TChangeLink;
+    FImages: TCustomImageList;
+    FOnChange: TNotifyEvent;
+    FOnExecute: TActionEvent;
+    FOnUpdate: TActionEvent;
+    FState: TActionListState;
+    function GetAction(Index: Integer): TContainedAction;
+    function GetActionCount: Integer;
+    procedure ImageListChange(Sender: TObject);
+    procedure SetAction(Index: Integer; Value: TContainedAction);
+    procedure SetState(const Value: TActionListState);
+  protected
+    procedure AddAction(Action: TContainedAction);
+    procedure RemoveAction(Action: TContainedAction);
+    procedure Change; virtual;
+    procedure GetChildren(Proc: TGetChildProc; Root: TComponent); override;
+    procedure Notification(AComponent: TComponent;
+      Operation: TOperation); override;
+    procedure SetChildOrder(Component: TComponent; Order: Integer); override;
+    procedure SetImages(Value: TCustomImageList); virtual;
+    property OnChange: TNotifyEvent read FOnChange write FOnChange;
+    property OnExecute: TActionEvent read FOnExecute write FOnExecute;
+    property OnUpdate: TActionEvent read FOnUpdate write FOnUpdate;
+  public
+    constructor Create(AOwner: TComponent); override;
+    destructor Destroy; override;
+    function ExecuteAction(Action: TBasicAction): Boolean; override;
+    //function IsShortCut(var Message: TWMKey): Boolean;
+    function UpdateAction(Action: TBasicAction): Boolean; override;
+    property Actions[Index: Integer]: TContainedAction
+      read GetAction write SetAction; default;
+    property ActionCount: Integer read GetActionCount;
+    property Images: TCustomImageList read FImages write SetImages;
+    property State: TActionListState read FState write SetState default asNormal;
+  end;
+
+
+  { TActionList }
+
+  TActionList = class(TCustomActionList)
+  published
+    property Images;
+    property State;
+    property OnChange;
+    property OnExecute;
+    property OnUpdate;
+  end;
+
+
+  { TShortCutList }
+
+  TShortCutList = class(TStringList)
+  private
+    function GetShortCuts(Index: Integer): TShortCut;
+  public
+    function Add(const S: String): Integer; override;
+    function IndexOfShortCut(const Shortcut: TShortCut): Integer;
+    property ShortCuts[Index: Integer]: TShortCut read GetShortCuts;
+  end;
+
+
+  { TControlAction }
+
+  THintEvent = procedure (var HintStr: string; var CanShow: Boolean) of object;
+
+  TCustomAction = class(TContainedAction)
+  private
+    FDisableIfNoHandler: Boolean;
+    FCaption: string;
+    FChecking: Boolean;
+    FChecked: Boolean;
+    FEnabled: Boolean;
+    FGroupIndex: Integer;
+    FHelpType: THelpType;
+    FHelpContext: THelpContext;
+    FHelpKeyword: string;
+    FHint: string;
+    FImageIndex: TImageIndex;
+    FShortCut: TShortCut;
+    FVisible: Boolean;
+    FOnHint: THintEvent;
+    FSecondaryShortCuts: TShortCutList;
+    FSavedEnabledState: Boolean;
+    FAutoCheck: Boolean;
+    procedure SetAutoCheck(Value: Boolean);
+    procedure SetCaption(const Value: string);
+    procedure SetChecked(Value: Boolean);
+    procedure SetEnabled(Value: Boolean);
+    procedure SetGroupIndex(const Value: Integer);
+    procedure SetHelpContext(Value: THelpContext); virtual;
+    procedure SetHelpKeyword(const Value: string); virtual;
+    procedure SetHelpType(Value: THelpType);
+    procedure SetHint(const Value: string);
+    procedure SetImageIndex(Value: TImageIndex);
+    procedure SetShortCut(Value: TShortCut);
+    procedure SetVisible(Value: Boolean);
+    function GetSecondaryShortCuts: TShortCutList;
+    procedure SetSecondaryShortCuts(const Value: TShortCutList);
+    function IsSecondaryShortCutsStored: Boolean;
+  protected
+    FImage: TObject;
+    FMask: TObject;
+    procedure AssignTo(Dest: TPersistent); override;
+    procedure SetName(const Value: TComponentName); override;
+    function HandleShortCut: Boolean; virtual;
+    property SavedEnabledState: Boolean
+      read FSavedEnabledState write FSavedEnabledState;
+  public
+    constructor Create(AOwner: TComponent); override;
+    destructor Destroy; override;
+    function DoHint(var HintStr: string): Boolean; dynamic;
+    function Execute: Boolean; override;
+    property AutoCheck: Boolean
+      read FAutoCheck write  SetAutoCheck default False;
+    property Caption: string read FCaption write SetCaption;
+    property Checked: Boolean read FChecked write SetChecked default False;
+    property DisableIfNoHandler: Boolean
+      read FDisableIfNoHandler write FDisableIfNoHandler default False;
+    property Enabled: Boolean read FEnabled write SetEnabled default True;
+    property GroupIndex: Integer read FGroupIndex write SetGroupIndex default 0;
+    property HelpContext: THelpContext
+      read FHelpContext write SetHelpContext default 0;
+    property HelpKeyword: string read FHelpKeyword write SetHelpKeyword;
+    property HelpType: THelpType
+      read FHelpType write SetHelpType default htKeyword;
+    property Hint: string read FHint write SetHint;
+    property ImageIndex: TImageIndex
+      read FImageIndex write SetImageIndex default -1;
+    property ShortCut: TShortCut read FShortCut write SetShortCut default 0;
+    property SecondaryShortCuts: TShortCutList read GetSecondaryShortCuts
+      write SetSecondaryShortCuts stored IsSecondaryShortCutsStored;
+    property Visible: Boolean read FVisible write SetVisible default True;
+    property OnHint: THintEvent read FOnHint write FOnHint;
+  end;
+
+
+  { TAction }
+
+  TAction = class(TCustomAction)
+  public
+    constructor Create(AOwner: TComponent); override;
+  published
+    property AutoCheck;
+    property Caption;
+    property Checked;
+    property Enabled;
+    property GroupIndex;
+    property HelpContext;
+    property HelpKeyword;
+    property HelpType;
+    property Hint;
+    property ImageIndex;
+    property ShortCut;
+    property SecondaryShortCuts;
+    property Visible;
+    property OnExecute;
+    property OnHint;
+    property OnUpdate;
+  end;
+
+
+  { TActionLink }
+
+  TActionLink = class(TBasicActionLink)
+  protected
+    function IsCaptionLinked: Boolean; virtual;
+    function IsCheckedLinked: Boolean; virtual;
+    function IsEnabledLinked: Boolean; virtual;
+    function IsGroupIndexLinked: Boolean; virtual;
+    function IsHelpContextLinked: Boolean; virtual;
+    function IsHelpLinked: Boolean; virtual;
+    function IsHintLinked: Boolean; virtual;
+    function IsImageIndexLinked: Boolean; virtual;
+    function IsShortCutLinked: Boolean; virtual;
+    function IsVisibleLinked: Boolean; virtual;
+    procedure SetAutoCheck(Value: Boolean); virtual;
+    procedure SetCaption(const Value: string); virtual;
+    procedure SetChecked(Value: Boolean); virtual;
+    procedure SetEnabled(Value: Boolean); virtual;
+    procedure SetGroupIndex(Value: Integer); virtual;
+    procedure SetHelpContext(Value: THelpContext); virtual;
+    procedure SetHelpKeyword(const Value: string); virtual;
+    procedure SetHelpType(Value: THelpType); virtual;
+    procedure SetHint(const Value: string); virtual;
+    procedure SetImageIndex(Value: Integer); virtual;
+    procedure SetShortCut(Value: TShortCut); virtual;
+    procedure SetVisible(Value: Boolean); virtual;
+  end;
+
+  TActionLinkClass = class of TActionLink;
+
+
+
+  TEnumActionProc = procedure (const Category: string;
+    ActionClass: TBasicActionClass; Info: Pointer) of object;
+
+procedure RegisterActions(const CategoryName: string;
+  const AClasses: array of TBasicActionClass; Resource: TComponentClass);
+procedure UnRegisterActions(const AClasses: array of TBasicActionClass);
+procedure EnumRegisteredActions(Proc: TEnumActionProc; Info: Pointer);
+function CreateAction(AOwner: TComponent;
+  ActionClass: TBasicActionClass): TBasicAction;
+
+const
+  RegisterActionsProc: procedure (const CategoryName: string;
+    const AClasses: array of TBasicActionClass; Resource: TComponentClass)= nil;
+  UnRegisterActionsProc:
+    procedure (const AClasses: array of TBasicActionClass) = nil;
+  EnumRegisteredActionsProc:
+    procedure (Proc: TEnumActionProc; Info: Pointer) = nil;
+  CreateActionProc:
+    function (AOwner: TComponent;
+              ActionClass: TBasicActionClass): TBasicAction = nil;
+
+
+implementation
+
+
+uses
+  Forms, Menus;
+
+const
+  SInvalidActionRegistration = 'Invalid action registration';
+  SInvalidActionUnregistration = 'Invalid action unregistration';
+  SInvalidActionEnumeration = 'Invalid action enumeration';
+  SInvalidActionCreation = 'Invalid action creation';
+
+
+procedure RegisterActions(const CategoryName: string;
+  const AClasses: array of TBasicActionClass; Resource: TComponentClass);
+begin
+  if Assigned(RegisterActionsProc) then
+    RegisterActionsProc(CategoryName, AClasses, Resource) else
+    raise Exception.Create(SInvalidActionRegistration);
+end;
+
+procedure UnRegisterActions(const AClasses: array of TBasicActionClass);
+begin
+  if Assigned(UnRegisterActionsProc) then
+    UnRegisterActionsProc(AClasses) else
+    raise Exception.Create(SInvalidActionUnregistration);
+end;
+
+procedure EnumRegisteredActions(Proc: TEnumActionProc; Info: Pointer);
+begin
+  if Assigned(EnumRegisteredActionsProc) then
+    EnumRegisteredActionsProc(Proc, Info) else
+    raise Exception.Create(SInvalidActionEnumeration);
+end;
+
+function CreateAction(AOwner: TComponent;
+  ActionClass: TBasicActionClass): TBasicAction;
+begin
+  if Assigned(CreateActionProc) then
+    Result := CreateActionProc(AOwner, ActionClass) else
+    raise Exception.Create(SInvalidActionCreation);
+end;
+
+{$I containedaction.inc}
+{$I customactionlist.inc}
+{$I actionlink.inc}
+{$I shortcutlist.inc}
+{$I customaction.inc}
+{$I action.inc}
+
+end.
+

lcl/imglist.pp

@@ -43,9 +43,8 @@ interface
 uses
   SysUtils, Classes, Graphics, GraphType, vclGlobals;
 
-
-
 type
+  TImageIndex = type integer;
 
   { TChangeLink }
   {
@@ -151,6 +150,9 @@ end.
 
 {
   $Log$
+  Revision 1.7  2002/08/06 19:57:39  lazarus
+  MG: added actnlist.pp
+
   Revision 1.6  2002/05/10 06:05:50  lazarus
   MG: changed license to LGPL
 

lcl/include/action.inc

@@ -0,0 +1,24 @@
+// included by actnlist.pas
+
+{
+ *****************************************************************************
+ *                                                                           *
+ *  This file is part of the Lazarus Component Library (LCL)                 *
+ *                                                                           *
+ *  See the file COPYING.LCL, included in this distribution,                 *
+ *  for details about the copyright.                                         *
+ *                                                                           *
+ *  This program is distributed in the hope that it will be useful,          *
+ *  but WITHOUT ANY WARRANTY; without even the implied warranty of           *
+ *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.                     *
+ *                                                                           *
+ *****************************************************************************
+}
+constructor TAction.Create(AOwner: TComponent);
+begin
+  inherited Create(AOwner);
+  DisableIfNoHandler := True;
+end;
+
+// included by actnlist.pas
+

lcl/include/actionlink.inc

@@ -0,0 +1,131 @@
+// included by actnlist.pas
+
+{
+ *****************************************************************************
+ *                                                                           *
+ *  This file is part of the Lazarus Component Library (LCL)                 *
+ *                                                                           *
+ *  See the file COPYING.LCL, included in this distribution,                 *
+ *  for details about the copyright.                                         *
+ *                                                                           *
+ *  This program is distributed in the hope that it will be useful,          *
+ *  but WITHOUT ANY WARRANTY; without even the implied warranty of           *
+ *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.                     *
+ *                                                                           *
+ *****************************************************************************
+}
+
+{ TActionLink }
+
+function TActionLink.IsCaptionLinked: Boolean;
+begin
+  Result := Action is TCustomAction;
+end;
+
+function TActionLink.IsCheckedLinked: Boolean;
+begin
+  Result := Action is TCustomAction;
+end;
+
+function TActionLink.IsEnabledLinked: Boolean;
+begin
+  Result := Action is TCustomAction;
+end;
+
+function TActionLink.IsGroupIndexLinked: Boolean;
+begin
+  Result := Action is TCustomAction;
+end;
+
+function TActionLink.IsHelpContextLinked: Boolean;
+begin
+  Result := Action is TCustomAction;
+end;
+
+function TActionLink.IsHelpLinked: Boolean;
+begin
+  Result := Action is TCustomAction;
+end;
+
+function TActionLink.IsHintLinked: Boolean;
+begin
+  Result := Action is TCustomAction;
+end;
+
+function TActionLink.IsImageIndexLinked: Boolean;
+begin
+  Result := Action is TCustomAction;
+end;
+
+function TActionLink.IsShortCutLinked: Boolean;
+begin
+  Result := Action is TCustomAction;
+end;
+
+function TActionLink.IsVisibleLinked: Boolean;
+begin
+  Result := Action is TCustomAction;
+end;
+
+procedure TActionLink.SetAutoCheck(Value: Boolean);
+begin
+
+end;
+
+procedure TActionLink.SetCaption(const Value: string);
+begin
+
+end;
+
+procedure TActionLink.SetChecked(Value: Boolean);
+begin
+
+end;
+
+procedure TActionLink.SetEnabled(Value: Boolean);
+begin
+
+end;
+
+procedure TActionLink.SetGroupIndex(Value: Integer);
+begin
+
+end;
+
+procedure TActionLink.SetHelpContext(Value: THelpContext);
+begin
+
+end;
+
+procedure TActionLink.SetHelpKeyword(const Value: string);
+begin
+
+end;
+
+procedure TActionLink.SetHelpType(Value: THelpType);
+begin
+
+end;
+
+procedure TActionLink.SetHint(const Value: string);
+begin
+
+end;
+
+procedure TActionLink.SetImageIndex(Value: Integer);
+begin
+
+end;
+
+procedure TActionLink.SetShortCut(Value: TShortCut);
+begin
+
+end;
+
+procedure TActionLink.SetVisible(Value: Boolean);
+begin
+
+end;
+
+// included by actnlist.pas
+

lcl/include/containedaction.inc

@@ -0,0 +1,128 @@
+// included by actnlist.pas
+
+{
+ *****************************************************************************
+ *                                                                           *
+ *  This file is part of the Lazarus Component Library (LCL)                 *
+ *                                                                           *
+ *  See the file COPYING.LCL, included in this distribution,                 *
+ *  for details about the copyright.                                         *
+ *                                                                           *
+ *  This program is distributed in the hope that it will be useful,          *
+ *  but WITHOUT ANY WARRANTY; without even the implied warranty of           *
+ *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.                     *
+ *                                                                           *
+ *****************************************************************************
+}
+
+
+{ TContainedAction }
+
+destructor TContainedAction.Destroy;
+begin
+  if ActionList <> nil then ActionList.RemoveAction(Self);
+  inherited Destroy;
+end;
+
+function TContainedAction.GetIndex: Integer;
+begin
+  if ActionList <> nil then
+    Result := ActionList.FActions.IndexOf(Self) else
+    Result := -1;
+end;
+
+function TContainedAction.IsCategoryStored: Boolean;
+begin
+  Result := True;//GetParentComponent <> ActionList;
+end;
+
+function TContainedAction.GetParentComponent: TComponent;
+begin
+  if ActionList <> nil then
+    Result := ActionList else
+    Result := inherited GetParentComponent;
+end;
+
+function TContainedAction.HasParent: Boolean;
+begin
+  if ActionList <> nil then
+    Result := True else
+    Result := inherited HasParent;
+end;
+
+procedure TContainedAction.ReadState(Reader: TReader);
+begin
+  inherited ReadState(Reader);
+  if Reader.Parent is TCustomActionList then
+    ActionList := TCustomActionList(Reader.Parent);
+end;
+
+procedure TContainedAction.SetIndex(Value: Integer);
+var
+  CurIndex, Count: Integer;
+begin
+  CurIndex := GetIndex;
+  if CurIndex >= 0 then
+  begin
+    Count := ActionList.FActions.Count;
+    if Value < 0 then Value := 0;
+    if Value >= Count then Value := Count - 1;
+    if Value <> CurIndex then
+    begin
+      ActionList.FActions.Delete(CurIndex);
+      ActionList.FActions.Insert(Value, Self);
+    end;
+  end;
+end;
+
+procedure TContainedAction.SetCategory(const Value: string);
+begin
+  if Value <> Category then
+  begin
+    FCategory := Value;
+    if ActionList <> nil then
+      ActionList.Change;
+  end;
+end;
+
+procedure TContainedAction.SetActionList(AActionList: TCustomActionList);
+begin
+  if AActionList <> ActionList then
+  begin
+    if ActionList <> nil then ActionList.RemoveAction(Self);
+    if AActionList <> nil then AActionList.AddAction(Self);
+  end;
+end;
+
+procedure TContainedAction.SetParentComponent(AParent: TComponent);
+begin
+  if not (csLoading in ComponentState) and (AParent is TCustomActionList) then
+    ActionList := TCustomActionList(AParent);
+end;
+
+procedure TContainedAction.Change;
+begin
+  inherited Change;
+end;
+
+function TContainedAction.Execute: Boolean;
+begin
+  Result := (ActionList <> nil) and ActionList.ExecuteAction(Self)
+    or Application.ExecuteAction(Self)
+    or inherited Execute;
+    // ToDo:
+    //or (SendAppMessage(CM_ACTIONEXECUTE, 0, Longint(Self)) = 1);
+end;
+
+function TContainedAction.Update: Boolean;
+begin
+  Result := (ActionList <> nil)
+    and ActionList.UpdateAction(Self)
+    or Application.UpdateAction(Self)
+    or inherited Update;
+    // ToDo:
+    //or (SendAppMessage(CM_ACTIONUPDATE, 0, Longint(Self)) = 1);
+end;
+
+// included by actnlist.pas
+

lcl/include/customaction.inc

@@ -0,0 +1,337 @@
+// included by actnlist.pas
+
+{
+ *****************************************************************************
+ *                                                                           *
+ *  This file is part of the Lazarus Component Library (LCL)                 *
+ *                                                                           *
+ *  See the file COPYING.LCL, included in this distribution,                 *
+ *  for details about the copyright.                                         *
+ *                                                                           *
+ *  This program is distributed in the hope that it will be useful,          *
+ *  but WITHOUT ANY WARRANTY; without even the implied warranty of           *
+ *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.                     *
+ *                                                                           *
+ *****************************************************************************
+}
+
+constructor TCustomAction.Create(AOwner: TComponent);
+begin
+  inherited Create(AOwner);
+  FEnabled := True;
+  FImageIndex := -1;
+  FVisible := True;
+  FSecondaryShortCuts := nil;
+end;
+
+destructor TCustomAction.Destroy;
+begin
+  FImage.Free;
+  FMask.Free;
+  if Assigned(FSecondaryShortCuts) then
+    FreeAndNil(FSecondaryShortCuts);
+  inherited Destroy;
+end;
+
+procedure TCustomAction.AssignTo(Dest: TPersistent);
+begin
+  if Dest is TCustomAction then
+    with TCustomAction(Dest) do
+    begin
+      Caption := Self.Caption;
+      Checked := Self.Checked;
+      Enabled := Self.Enabled;
+      HelpContext := Self.HelpContext;
+      Hint := Self.Hint;
+      ImageIndex := Self.ImageIndex;
+      ShortCut := Self.ShortCut;
+      Visible := Self.Visible;
+      OnExecute := Self.OnExecute;
+      OnUpdate := Self.OnUpdate;
+      OnChange := Self.OnChange;
+    end else inherited AssignTo(Dest);
+end;
+
+procedure TCustomAction.SetAutoCheck(Value: Boolean);
+var
+  I: Integer;
+begin
+  if Value <> FAutoCheck then
+  begin
+    for I := 0 to FClients.Count - 1 do
+      if TBasicActionLink(FClients[I]) is TActionLink then
+        TActionLink(FClients[I]).SetAutoCheck(Value);
+    FAutoCheck := Value;
+    Change;
+  end;
+end;
+
+procedure TCustomAction.SetCaption(const Value: string);
+var
+  I: Integer;
+  Link: TActionLink;
+begin
+  if Value <> FCaption then
+  begin
+    for I := 0 to FClients.Count - 1 do
+    begin
+      Link := TObject(FClients.List^[I]) as TActionLink;
+      if Assigned(Link) then
+        Link.SetCaption(Value);
+    end;
+    FCaption := Value;
+    Change;
+  end;
+end;
+
+procedure TCustomAction.SetChecked(Value: Boolean);
+var
+  I: Integer;
+  Link: TActionLink;
+  Action: TContainedAction;
+begin
+  if FChecking then exit;
+  FChecking := True;
+  try
+    if Value <> FChecked then
+    begin
+      for I := 0 to FClients.Count - 1 do
+      begin
+        Link := TObject(FClients.List^[I]) as TActionLink;
+        if Assigned(Link) then
+          Link.SetChecked(Value);
+      end;
+      FChecked := Value;
+      if (FGroupIndex > 0) and FChecked then
+        for I := 0 to ActionList.ActionCount - 1 do
+        begin
+          Action := ActionList.Actions[I];
+          if (Action <> Self) and
+             (TObject(Action) is TCustomAction) and
+             (TCustomAction(Action).FGroupIndex = FGroupIndex) then
+            TCustomAction(Action).Checked := False;
+        end;
+      Change;
+    end;
+  finally
+    FChecking := False;
+  end;
+end;
+
+procedure TCustomAction.SetEnabled(Value: Boolean);
+var
+  I: Integer;
+  Link: TActionLink;
+begin
+  if Value <> FEnabled then
+  begin
+    if Assigned(ActionList) then
+      if ActionList.State = asSuspended then
+      begin
+        FEnabled := Value;
+        exit;
+      end
+      else
+        if (ActionList.State = asSuspendedEnabled) then
+          Value := True;
+    for I := 0 to FClients.Count - 1 do
+    begin
+      Link := TObject(FClients.List^[I]) as TActionLink;
+      if Assigned(Link) then
+        TActionLink(Link).SetEnabled(Value);
+    end;
+    FEnabled := Value;
+    Change;
+  end;
+end;
+
+procedure TCustomAction.SetGroupIndex(const Value: Integer);
+var
+  I: Integer;
+  Link: TActionLink;
+begin
+  if Value <> FGroupIndex then
+  begin
+    FGroupIndex := Value;
+    for I := 0 to FClients.Count - 1 do
+    begin
+      Link := TObject(FClients.List^[I]) as TActionLink;
+      if Assigned(Link) then
+        Link.SetGroupIndex(Value);
+    end;
+    Change;
+  end;
+end;
+
+procedure TCustomAction.SetHelpType(Value: THelpType);
+var
+  I: Integer;
+begin
+  if Value <> FHelpType then
+  begin
+    for I := 0 to FClients.Count -1 do
+     if TBasicActionLink(FCLients[I]) is TActionLink then
+       TActionLink(FClients[I]).SetHelpType(Value);
+    FHelpType := Value;
+    Change;
+  end;
+end;
+
+procedure TCustomAction.SetHelpKeyword(const Value: string);
+var
+  I: Integer;
+begin
+  if Value <> FHelpKeyword then
+  begin
+    for I := 0 to FClients.Count -1 do
+     if TBasicActionLink(FCLients[I]) is TActionLink then
+       TActionLink(FClients[I]).SetHelpKeyword(Value);
+    FHelpKeyword := Value;
+    Change;
+  end;
+end;
+
+procedure TCustomAction.SetHelpContext(Value: THelpContext);
+var
+  I: Integer;
+  Link: TActionLink;
+begin
+  if Value <> FHelpContext then
+  begin
+    for I := 0 to FClients.Count - 1 do
+    begin
+      Link := TObject(FClients.List^[I]) as TActionLink;
+      if Assigned(Link) then
+        Link.SetHelpContext(Value);
+    end;
+    FHelpContext := Value;
+    Change;
+  end;
+end;
+
+procedure TCustomAction.SetHint(const Value: string);
+var
+  I: Integer;
+  Link: TActionLink;
+begin
+  if Value <> FHint then
+  begin
+    for I := 0 to FClients.Count - 1 do
+    begin
+      Link := TObject(FClients.List^[I]) as TActionLink;
+      if Assigned(Link) then
+        Link.SetHint(Value);
+    end;
+    FHint := Value;
+    Change;
+  end;
+end;
+
+procedure TCustomAction.SetImageIndex(Value: TImageIndex);
+var
+  I: Integer;
+  Link: TActionLink;
+begin
+  if Value <> FImageIndex then
+  begin
+    for I := 0 to FClients.Count - 1 do
+    begin
+      Link := TObject(FClients.List^[I]) as TActionLink;
+      if Assigned(Link) then
+        Link.SetImageIndex(Value);
+    end;
+    FImageIndex := Value;
+    Change;
+  end;
+end;
+
+procedure TCustomAction.SetShortCut(Value: TShortCut);
+var
+  I: Integer;
+  Link: TActionLink;
+begin
+  if Value <> FShortCut then
+  begin
+    for I := 0 to FClients.Count - 1 do
+    begin
+      Link := TObject(FClients.List^[I]) as TActionLink;
+      if Assigned(Link) then
+        Link.SetShortCut(Value);
+    end;
+    FShortCut := Value;
+    Change;
+  end;
+end;
+
+procedure TCustomAction.SetVisible(Value: Boolean);
+var
+  I: Integer;
+  Link: TActionLink;
+begin
+  if Value <> FVisible then
+  begin
+    for I := 0 to FClients.Count - 1 do
+    begin
+      Link := TObject(FClients.List^[I]) as TActionLink;
+      if Assigned(Link) then
+        TActionLink(FClients[I]).SetVisible(Value);
+    end;
+    FVisible := Value;
+    Change;
+  end;
+end;
+
+procedure TCustomAction.SetName(const Value: TComponentName);
+var
+  ChangeText: Boolean;
+begin
+  ChangeText := (Name = Caption) and ((Owner = nil) or
+    not (csLoading in Owner.ComponentState));
+  inherited SetName(Value);
+  { Don't update caption to name if we've got clients connected. }
+  if ChangeText and (FClients.Count = 0) then Caption := Value;
+end;
+
+function TCustomAction.DoHint(var HintStr: string): Boolean;
+begin
+  Result := True;
+  if Assigned(FOnHint) then FOnHint(HintStr, Result);
+end;
+
+function TCustomAction.Execute: Boolean;
+begin
+  Result := False;
+  if Assigned(ActionList) and (ActionList.State <> asNormal) then Exit;
+  Update;
+  if FAutoCheck then
+    Checked := not Checked;
+  Result := Enabled and inherited Execute;
+end;
+
+function TCustomAction.GetSecondaryShortCuts: TShortCutList;
+begin
+  if FSecondaryShortCuts = nil then
+    FSecondaryShortCuts := TShortCutList.Create;
+  Result := FSecondaryShortCuts;
+end;
+
+procedure TCustomAction.SetSecondaryShortCuts(const Value: TShortCutList);
+begin
+  if FSecondaryShortCuts = nil then
+    FSecondaryShortCuts := TShortCutList.Create;
+  FSecondaryShortCuts.Assign(Value);
+end;
+
+function TCustomAction.IsSecondaryShortCutsStored: Boolean;
+begin
+  Result := Assigned(FSecondaryShortCuts) and (FSecondaryShortCuts.Count > 0);
+end;
+
+function TCustomAction.HandleShortCut: Boolean;
+begin
+  Result := Execute;
+end;
+
+
+// included by actnlist.pas
+

lcl/include/menuactionlink.inc

@@ -0,0 +1,147 @@
+// included by menus.pas
+
+{
+ *****************************************************************************
+ *                                                                           *
+ *  This file is part of the Lazarus Component Library (LCL)                 *
+ *                                                                           *
+ *  See the file COPYING.LCL, included in this distribution,                 *
+ *  for details about the copyright.                                         *
+ *                                                                           *
+ *  This program is distributed in the hope that it will be useful,          *
+ *  but WITHOUT ANY WARRANTY; without even the implied warranty of           *
+ *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.                     *
+ *                                                                           *
+ *****************************************************************************
+}
+{ TMenuActionLink }
+
+procedure TMenuActionLink.AssignClient(AClient: TObject);
+begin
+  FClient := AClient as TMenuItem;
+end;
+
+function TMenuActionLink.IsAutoCheckLinked: Boolean;
+begin
+  Result:=false;
+  // ToDo:
+  //Result := FClient.AutoCheck = (Action as TCustomAction).AutoCheck;
+end;
+
+function TMenuActionLink.IsCaptionLinked: Boolean;
+begin
+  Result := inherited IsCaptionLinked and
+        (AnsiCompareText(FClient.Caption, (Action as TCustomAction).Caption)=0);
+end;
+
+function TMenuActionLink.IsCheckedLinked: Boolean;
+begin
+  Result := inherited IsCheckedLinked and
+    (FClient.Checked = (Action as TCustomAction).Checked);
+end;
+
+function TMenuActionLink.IsEnabledLinked: Boolean;
+begin
+  Result := inherited IsEnabledLinked and
+    (FClient.Enabled = (Action as TCustomAction).Enabled);
+end;
+
+function TMenuActionLink.IsHelpContextLinked: Boolean;
+begin
+  Result:=false;
+  // ToDo:
+  //Result := inherited IsHelpContextLinked and
+  //  (FClient.HelpContext = (Action as TCustomAction).HelpContext);
+end;
+
+function TMenuActionLink.IsHintLinked: Boolean;
+begin
+  Result := inherited IsHintLinked and
+    (FClient.Hint = (Action as TCustomAction).Hint);
+end;
+
+function TMenuActionLink.IsGroupIndexLinked: Boolean;
+begin
+  Result := FClient.RadioItem and inherited IsGroupIndexLinked and
+    (FClient.GroupIndex = (Action as TCustomAction).GroupIndex);
+end;
+
+function TMenuActionLink.IsImageIndexLinked: Boolean;
+begin
+  Result := inherited IsImageIndexLinked and
+    (FClient.ImageIndex = (Action as TCustomAction).ImageIndex);
+end;
+
+function TMenuActionLink.IsShortCutLinked: Boolean;
+begin
+  Result := inherited IsShortCutLinked and
+    (FClient.ShortCut = (Action as TCustomAction).ShortCut);
+end;
+
+function TMenuActionLink.IsVisibleLinked: Boolean;
+begin
+  Result := inherited IsVisibleLinked and
+    (FClient.Visible = (Action as TCustomAction).Visible);
+end;
+
+function TMenuActionLink.IsOnExecuteLinked: Boolean;
+begin
+  Result := inherited IsOnExecuteLinked and
+    (@FClient.OnClick = @Action.OnExecute);
+end;
+
+procedure TMenuActionLink.SetAutoCheck(Value: Boolean);
+begin
+  // ToDo:
+  //if IsAutoCheckLinked then FClient.AutoCheck := Value;
+end;
+
+procedure TMenuActionLink.SetCaption(const Value: string);
+begin
+  if IsCaptionLinked then FClient.Caption := Value;
+end;
+
+procedure TMenuActionLink.SetChecked(Value: Boolean);
+begin
+  if IsCheckedLinked then FClient.Checked := Value;
+end;
+
+procedure TMenuActionLink.SetEnabled(Value: Boolean);
+begin
+  if IsEnabledLinked then FClient.Enabled := Value;
+end;
+
+procedure TMenuActionLink.SetHelpContext(Value: THelpContext);
+begin
+  // ToDo:
+  //if IsHelpContextLinked then FClient.HelpContext := Value;
+end;
+
+procedure TMenuActionLink.SetHint(const Value: string);
+begin
+  if IsHintLinked then FClient.Hint := Value;
+end;
+
+procedure TMenuActionLink.SetImageIndex(Value: Integer);
+begin
+  if IsImageIndexLinked then FClient.ImageIndex := Value;
+end;
+
+procedure TMenuActionLink.SetShortCut(Value: TShortCut);
+begin
+  if IsShortCutLinked then FClient.ShortCut := Value;
+end;
+
+procedure TMenuActionLink.SetVisible(Value: Boolean);
+begin
+  if IsVisibleLinked then FClient.Visible := Value;
+end;
+
+procedure TMenuActionLink.SetOnExecute(Value: TNotifyEvent);
+begin
+  if IsOnExecuteLinked then FClient.OnClick := Value;
+end;
+
+
+// included by menus.pas
+

lcl/include/menuitem.inc

@@ -208,6 +208,16 @@ begin
   Result := FParent;
 end;
 
+{------------------------------------------------------------------------------
+  function TMenuItem.IsCaptionStored: boolean;
+
+  Checks if Caption needs to be saved to stream
+ ------------------------------------------------------------------------------}
+function TMenuItem.IsCaptionStored: boolean;
+begin
+  Result := (ActionLink = nil) or not FActionLink.IsCaptionLinked;
+end;
+
 {------------------------------------------------------------------------------
   Function: TMenuItem.GetParentMenu
   Params:   none
@@ -577,6 +587,9 @@ end;
 { =============================================================================
 
   $Log$
+  Revision 1.17  2002/08/06 19:57:40  lazarus
+  MG: added actnlist.pp
+
   Revision 1.16  2002/08/05 10:45:03  lazarus
   MG: TMenuItem.Caption can now be set after creation
 
@@ -653,6 +666,9 @@ end;
 
 
   $Log$
+  Revision 1.17  2002/08/06 19:57:40  lazarus
+  MG: added actnlist.pp
+
   Revision 1.16  2002/08/05 10:45:03  lazarus
   MG: TMenuItem.Caption can now be set after creation
 

lcl/include/shortcutlist.inc

@@ -0,0 +1,48 @@
+// included by actnlist.pas
+
+{
+ *****************************************************************************
+ *                                                                           *
+ *  This file is part of the Lazarus Component Library (LCL)                 *
+ *                                                                           *
+ *  See the file COPYING.LCL, included in this distribution,                 *
+ *  for details about the copyright.                                         *
+ *                                                                           *
+ *  This program is distributed in the hope that it will be useful,          *
+ *  but WITHOUT ANY WARRANTY; without even the implied warranty of           *
+ *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.                     *
+ *                                                                           *
+ *****************************************************************************
+}
+
+function TShortCutList.Add(const S: String): Integer;
+var
+  ShortCut: TShortCut;
+  p: Pointer;
+begin
+  Result := inherited Add(S);
+  ShortCut:=TextToShortCut(S);
+  p:=Pointer(Cardinal(ShortCut));
+  Objects[Result] := TObject(p);
+end;
+
+function TShortCutList.GetShortCuts(Index: Integer): TShortCut;
+begin
+  Result := TShortCut(Cardinal(Objects[Index]));
+end;
+
+function TShortCutList.IndexOfShortCut(const Shortcut: TShortCut): Integer;
+var
+  I: Integer;
+begin
+  Result := -1;
+  for I := 0 to Count - 1 do
+    if TShortCut(Cardinal(Objects[I])) = ShortCut then
+    begin
+      Result := I;
+      break;
+    end;
+end;
+
+// included by actnlist.pas
+

lcl/menus.pp

@@ -45,7 +45,7 @@ interface
 {$endif}
 
 uses
-  VCLGlobals, Classes, SysUtils, LMessages;
+  VCLGlobals, Classes, SysUtils, LMessages, ActnList;
 
 
 type
@@ -59,8 +59,43 @@ type
   TMenuChangeEvent = procedure (Sender: TObject; Source: TMenuItem;
                                 Rebuild: Boolean) of object;
 
+  { TMenuActionLink }
+
+  TMenuActionLink = class(TActionLink)
+  protected
+    FClient: TMenuItem;
+    procedure AssignClient(AClient: TObject); override;
+    function IsAutoCheckLinked: Boolean; virtual;
+    function IsCaptionLinked: Boolean; override;
+    function IsCheckedLinked: Boolean; override;
+    function IsEnabledLinked: Boolean; override;
+    function IsHelpContextLinked: Boolean; override;
+    function IsHintLinked: Boolean; override;
+    function IsGroupIndexLinked: Boolean; override;
+    function IsImageIndexLinked: Boolean; override;
+    function IsShortCutLinked: Boolean; override;
+    function IsVisibleLinked: Boolean; override;
+    function IsOnExecuteLinked: Boolean; override;
+    procedure SetAutoCheck(Value: Boolean); override;
+    procedure SetCaption(const Value: string); override;
+    procedure SetChecked(Value: Boolean); override;
+    procedure SetEnabled(Value: Boolean); override;
+    procedure SetHelpContext(Value: THelpContext); override;
+    procedure SetHint(const Value: string); override;
+    procedure SetImageIndex(Value: Integer); override;
+    procedure SetShortCut(Value: TShortCut); override;
+    procedure SetVisible(Value: Boolean); override;
+    procedure SetOnExecute(Value: TNotifyEvent); override;
+  end;
+
+  TMenuActionLinkClass = class of TMenuActionLink;
+  
+  
+  { TMenuItem }
+
   TMenuItem = class(TComponent)//TWinControl)
   private
+    FActionLink: TMenuActionLink;
     FCaption: string;
     FChecked: Boolean;
     FCommand: integer;
@@ -81,6 +116,7 @@ type
     function GetCount: Integer;
     function GetItem(Index: Integer): TMenuItem;
     function GetParent: TMenuItem;
+    function IsCaptionStored: boolean;
     procedure SetCaption(const AValue: string);
     procedure SetChecked(AValue: Boolean);
     procedure SetDefault(AValue: Boolean);
@@ -90,6 +126,7 @@ type
     procedure TurnSiblingsOff;
     procedure VerifyGroupIndex(Position: Integer; Value: Byte);
   protected
+    property ActionLink: TMenuActionLink read FActionLink write FActionLink;
     procedure CreateHandle; virtual;
     procedure DoClicked(var msg); message LM_ACTIVATE;               //'activate';
     function GetHandle: HMenu;
@@ -118,7 +155,7 @@ type
     property Items[Index: Integer]: TMenuItem read GetItem; default;
     property Parent: TMenuItem read GetParent;
   published
-    property Caption: String read FCaption write SetCaption {stored IsCaptionStored};
+    property Caption: String read FCaption write SetCaption stored IsCaptionStored;
     property Checked: Boolean read FChecked write SetChecked {stored IsCheckedStored} default False;
     property Default: Boolean read FDefault write SetDefault default False;
     property Enabled: Boolean read FEnabled write SetEnabled {stored IsEnabledStored} default True;
@@ -190,6 +227,8 @@ type
 function ShortCut(const Key: Word; const Shift : TShiftState) : TShortCut;
 procedure ShortCuttoKey(const ShortCut : TShortCut; var Key: Word; var Shift : TShiftState);
 
+function TextToShortCut(Text: string): TShortCut;
+function ShortCutToText(ShortCut: TShortCut): string;
 
 
 implementation
@@ -208,12 +247,129 @@ begin
   CommandPool[Result] := True;
 end;
 
+type
+  TMenuKeyCap = (mkcBkSp, mkcTab, mkcEsc, mkcEnter, mkcSpace, mkcPgUp,
+    mkcPgDn, mkcEnd, mkcHome, mkcLeft, mkcUp, mkcRight, mkcDown, mkcIns,
+    mkcDel, mkcShift, mkcCtrl, mkcAlt);
+
+const
+  SmkcBkSp = 'BkSp';
+  SmkcTab = 'Tab';
+  SmkcEsc = 'Esc';
+  SmkcEnter = 'Enter';
+  SmkcSpace = 'Space';
+  SmkcPgUp = 'PgUp';
+  SmkcPgDn = 'PgDn';
+  SmkcEnd = 'End';
+  SmkcHome = 'Home';
+  SmkcLeft = 'Left';
+  SmkcUp = 'Up';
+  SmkcRight = 'Right';
+  SmkcDown = 'Down';
+  SmkcIns = 'Ins';
+  SmkcDel = 'Del';
+  SmkcShift = 'Shift+';
+  SmkcCtrl = 'Ctrl+';
+  SmkcAlt = 'Alt+';
+
+  MenuKeyCaps: array[TMenuKeyCap] of string = (
+    SmkcBkSp, SmkcTab, SmkcEsc, SmkcEnter, SmkcSpace, SmkcPgUp,
+    SmkcPgDn, SmkcEnd, SmkcHome, SmkcLeft, SmkcUp, SmkcRight,
+    SmkcDown, SmkcIns, SmkcDel, SmkcShift, SmkcCtrl, SmkcAlt);
+
+function GetSpecialName(ShortCut: TShortCut): string;
+{var
+  ScanCode: Integer;
+  KeyName: array[0..255] of Char;}
+begin
+  Result := '';
+  // ToDo:
+  {
+  ScanCode := MapVirtualKey(WordRec(ShortCut).Lo, 0) shl 16;
+  if ScanCode <> 0 then
+  begin
+    GetKeyNameText(ScanCode, KeyName, SizeOf(KeyName));
+    GetSpecialName := KeyName;
+  end;
+  }
+end;
+
+function ShortCutToText(ShortCut: TShortCut): string;
+var
+  Name: string;
+begin
+  case WordRec(ShortCut).Lo of
+    $08, $09:
+      Name := MenuKeyCaps[TMenuKeyCap(Ord(mkcBkSp) + WordRec(ShortCut).Lo - $08)];
+    $0D: Name := MenuKeyCaps[mkcEnter];
+    $1B: Name := MenuKeyCaps[mkcEsc];
+    $20..$28:
+      Name := MenuKeyCaps[TMenuKeyCap(Ord(mkcSpace) + WordRec(ShortCut).Lo - $20)];
+    $2D..$2E:
+      Name := MenuKeyCaps[TMenuKeyCap(Ord(mkcIns) + WordRec(ShortCut).Lo - $2D)];
+    $30..$39: Name := Chr(WordRec(ShortCut).Lo - $30 + Ord('0'));
+    $41..$5A: Name := Chr(WordRec(ShortCut).Lo - $41 + Ord('A'));
+    $60..$69: Name := Chr(WordRec(ShortCut).Lo - $60 + Ord('0'));
+    $70..$87: Name := 'F' + IntToStr(WordRec(ShortCut).Lo - $6F);
+  else
+    Name := GetSpecialName(ShortCut);
+  end;
+  if Name <> '' then
+  begin
+    Result := '';
+    if ShortCut and scShift <> 0 then Result := Result + MenuKeyCaps[mkcShift];
+    if ShortCut and scCtrl <> 0 then Result := Result + MenuKeyCaps[mkcCtrl];
+    if ShortCut and scAlt <> 0 then Result := Result + MenuKeyCaps[mkcAlt];
+    Result := Result + Name;
+  end
+  else Result := '';
+end;
+
+function TextToShortCut(Text: string): TShortCut;
+
+  { If the front of Text is equal to Front then remove the matching piece
+    from Text and return True, otherwise return False }
+
+  function CompareFront(var Text: string; const Front: string): Boolean;
+  begin
+    Result := False;
+    if (Length(Text) >= Length(Front)) and
+      (AnsiStrLIComp(PChar(Text), PChar(Front), Length(Front)) = 0) then
+    begin
+      Result := True;
+      Delete(Text, 1, Length(Front));
+    end;
+  end;
+
+var
+  Key: TShortCut;
+  Shift: TShortCut;
+begin
+  Result := 0;
+  Shift := 0;
+  while True do
+  begin
+    if CompareFront(Text, MenuKeyCaps[mkcShift]) then Shift := Shift or scShift
+    else if CompareFront(Text, '^') then Shift := Shift or scCtrl
+    else if CompareFront(Text, MenuKeyCaps[mkcCtrl]) then Shift := Shift or scCtrl
+    else if CompareFront(Text, MenuKeyCaps[mkcAlt]) then Shift := Shift or scAlt
+    else Break;
+  end;
+  if Text = '' then Exit;
+  for Key := $08 to $255 do { Copy range from table in ShortCutToText }
+    if AnsiCompareText(Text, ShortCutToText(Key)) = 0 then
+    begin
+      Result := Key or Shift;
+      Exit;
+    end;
+end;
 
 {$I menubar.inc}
 {$I menu.inc}
 {$I menuitem.inc}
 {$I mainmenu.inc}
 {$I popupmenu.inc}
+{$I menuactionlink.inc}
 
 Function ShortCut(const Key: Word; const Shift : TShiftState) : TShortCut;
 Begin
@@ -241,6 +397,9 @@ end.
 
 {
   $Log$
+  Revision 1.16  2002/08/06 19:57:39  lazarus
+  MG: added actnlist.pp
+
   Revision 1.15  2002/08/05 10:45:02  lazarus
   MG: TMenuItem.Caption can now be set after creation