{ /*************************************************************************** menus.pp -------- Component Library TMenu, TMenuItem, TMenuBar Controls Initial Revision : Mon Jul 26 0:10:12 1999 ***************************************************************************/ ***************************************************************************** * * * 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. * * * ***************************************************************************** } { TMenu, TMenuItem, TMenuBar @author(TMenu - Shane Miller ) @author(TMenuItem - Shane Miller ) @author(TMenuBar - Shane Miller ) @author(TMainMenu - Marc Weustink ) @author(TPopupMenu - Marc Weustink @created(26-Jul-1999) @lastmod(27-Oct-1999) Detailed description of the Unit. } unit Menus; {$mode objfpc}{$H+} interface {$ifdef Trace} {$ASSERTIONS ON} {$endif} uses Classes, SysUtils, LCLStrConsts, LCLIntf, LCLType, LCLProc, VCLGlobals, LMessages, ActnList, Graphics, ImgList; type TMenu = class; EMenuError = class(Exception); TMenuItem = class; 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) private FActionLink: TMenuActionLink; FAutoCheck: boolean; FCaption: string; FChecked: Boolean; FCommand: integer; FDefault: Boolean; FEnabled: Boolean; FGraphic: TGraphic; FGroupIndex: Byte; FHandle: HMenu; FHint: String; FImageIndex : Integer; FItems: TList; // list of TMenuItem FMenu: TMenu; FOnChange: TMenuChangeEvent; FOnClick: TNotifyEvent; FParent: TMenuItem; FRadioItem: Boolean; FRightJustify: boolean; FShortCut: TShortCut; FShowAlwaysCheckable: boolean; FSubMenuImages: TCustomImageList; FVisible: Boolean; function GetCount: Integer; function GetItem(Index: Integer): TMenuItem; function GetMenuIndex: Integer; function GetParent: TMenuItem; function IsCaptionStored: boolean; function IsCheckedStored: boolean; function IsEnabledStored: boolean; function IsShortCutStored: boolean; function IsVisibleStored: boolean; procedure SetAutoCheck(const AValue: boolean); procedure SetCaption(const AValue: string); procedure SetChecked(AValue: Boolean); procedure SetDefault(AValue: Boolean); procedure SetEnabled(AValue: Boolean); procedure SetGraphic(const AValue: TGraphic); procedure SetMenuIndex(AValue: Integer); procedure SetRadioItem(const AValue: Boolean); procedure SetRightJustify(const AValue: boolean); procedure SetShowAlwaysCheckable(const AValue: boolean); procedure SetSubMenuImages(const AValue: TCustomImageList); procedure ShortcutChanged(const OldValue, Value : TShortcut); procedure SubItemChanged(Sender: TObject; Source: TMenuItem; Rebuild: Boolean); procedure TurnSiblingsOff; (* * MWE: Disabled this feature, it makes not much sense * See comments below procedure VerifyGroupIndex(Position: Integer; Value: Byte); *) protected property ActionLink: TMenuActionLink read FActionLink write FActionLink; procedure CreateHandle; virtual; procedure DestroyHandle; virtual; procedure DoClicked(var msg); message LM_ACTIVATE; function GetHandle: HMenu; Procedure SetImageIndex(value : Integer); procedure SetGroupIndex(AValue: Byte); procedure SetShortCut(AValue : TShortCut); procedure SetVisible(AValue: Boolean); procedure MenuChanged(Rebuild : Boolean); procedure SetChildOrder(Child: TComponent; Order: Integer); override; procedure SetParentComponent(AValue : TComponent); override; procedure GetChildren(Proc: TGetChildProc; Root: TComponent); override; public FCompStyle : LongInt; constructor Create(TheOwner: TComponent); override; destructor Destroy; override; function GetImageList: TCustomImageList; virtual; function GetParentComponent: TComponent; override; function GetParentMenu: TMenu; virtual; function HandleAllocated : Boolean; function HasIcon: boolean; virtual; function HasParent : Boolean; override; function IndexOf(Item: TMenuItem): Integer; function IndexOfCaption(const ACaption: string): Integer; virtual; function IsCheckItem: boolean; virtual; procedure Add(Item: TMenuItem); procedure AddSeparator; procedure Click; virtual; procedure Delete(Index: Integer); procedure HandleNeeded; virtual; procedure Insert(Index: Integer; Item: TMenuItem); procedure RecreateHandle; virtual; procedure Remove(Item: TMenuItem); function IsInMenuBar: boolean; virtual; public property Count: Integer read GetCount; property Handle: HMenu read GetHandle write FHandle; property Items[Index: Integer]: TMenuItem read GetItem; default; property MenuIndex: Integer read GetMenuIndex write SetMenuIndex; property Parent: TMenuItem read GetParent; property Command: integer read FCommand; published property AutoCheck: boolean read FAutoCheck write SetAutoCheck default False; 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; property Graphic: TGraphic read FGraphic write SetGraphic; property GroupIndex: Byte read FGroupIndex write SetGroupIndex default 0; property Hint: String read FHint write FHint; property ImageIndex: Integer read FImageIndex write SetImageIndex; property RadioItem: Boolean read FRadioItem write SetRadioItem default False; property RightJustify: boolean read FRightJustify write SetRightJustify; property ShortCut: TShortCut read FShortCut write SetShortCut stored IsShortCutStored default 0; property ShowAlwaysCheckable: boolean read FShowAlwaysCheckable write SetShowAlwaysCheckable; property SubMenuImages: TCustomImageList read FSubMenuImages write SetSubMenuImages; property Visible: Boolean read FVisible write SetVisible stored IsVisibleStored default True; property OnClick: TNotifyEvent read FOnClick write FOnClick; end; { TMenu } TFindItemKind = (fkCommand, fkHandle, fkShortCut); TMenu = class(TComponent) private FImageChangeLink: TChangeLink; FImages: TCustomImageList; FItems: TMenuItem; FOnChange: TMenuChangeEvent; FParent: TComponent; procedure SetImages(const AValue: TCustomImageList); procedure SetParent(const AValue: TComponent); procedure ImageListChange(Sender: TObject); protected procedure CreateHandle; virtual; procedure DoChange(Source: TMenuItem; Rebuild: Boolean); virtual; function GetHandle: HMENU; virtual; procedure GetChildren(Proc: TGetChildProc; Root: TComponent); override; procedure MenuChanged(Sender: TObject; Source: TMenuItem; Rebuild: Boolean); virtual; property OnChange: TMenuChangeEvent read FOnChange write FOnChange; procedure UpdateItems; public FCompStyle: LongInt; constructor Create(AOwner: TComponent); override; destructor Destroy; override; function FindItem(AValue: Integer; Kind: TFindItemKind) : TMenuItem; function HandleAllocated: Boolean; Function IsRightToLeft: Boolean; procedure HandleNeeded; function DispatchCommand(ACommand: Word): Boolean; public property Handle: HMenu read GetHandle; property Parent: TComponent read FParent write SetParent; published property Items: TMenuItem read FItems; property Images: TCustomImageList read FImages write SetImages; end; { TMainMenu } TMainMenu = class(TMenu) protected procedure ItemChanged; public constructor Create(AOwner: TComponent); override; published property Items; property OnChange; end; { TPopupMenu } TPopupMenu = class(TMenu) private FAutoPopup : Boolean; FOnClose: TNotifyEvent; FOnPopup: TNotifyEvent; FPopupComponent : TComponent; FPopupPoint: TPoint; protected procedure DoPopup(Sender: TObject); virtual; public constructor Create(AOwner: TComponent); override; destructor Destroy; override; procedure PopUp(X, Y : Integer); property PopupComponent: TComponent read FPopupComponent write FPopupComponent; property PopupPoint: TPoint read FPopupPoint; procedure Close; procedure DoClose; published property AutoPopup: Boolean read FAutoPopup write FAutoPopup default True; property OnPopup: TNotifyEvent read FOnPopup write FOnPopup; property OnClose: TNotifyEvent read FOnClose write FOnClose; end; function ShortCut(const Key: Word; const Shift : TShiftState) : TShortCut; procedure ShortCutToKey(const ShortCut : TShortCut; var Key: Word; var Shift : TShiftState); function TextToShortCut(const ShortCutText: string): TShortCut; function ShortCutToText(ShortCut: TShortCut): string; var DesignerMenuItemClick: TNotifyEvent; ActivePopupMenu: TPopupMenu; procedure Register; implementation { Menu command managment } var CommandPool: TBits; function UniqueCommand: Word; begin if CommandPool=nil then CommandPool:=TBits.Create(32); Result := CommandPool.OpenBit; CommandPool[Result] := True; end; function ShortCutToText(ShortCut: TShortCut): string; begin Result:=ShortCutToShortCutText(ShortCut); end; procedure Register; begin RegisterComponents('Standard',[TMainMenu,TPopupMenu]); RegisterNoIcon([TMenuItem]); end; function TextToShortCut(const ShortCutText: string): TShortCut; begin Result:=ShortCutTextToShortCut(ShortCutText); end; {$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 Result := MapIrregularVirtualKey(Key); if WordRec(Result).Hi <> 0 then begin Result:=0; exit; end; if ssShift in Shift then Inc(Result,scShift); if ssCtrl in Shift then Inc(Result,scCtrl); if ssAlt in Shift then Inc(Result,scAlt); end; Procedure ShortCutToKey(const ShortCut : TShortCut; var Key: Word; var Shift : TShiftState); begin key := ShortCut and not(scShift+scAlt+scCtrl); Shift := []; if ShortCut and scShift <> 0 then Include(shift,ssShift); if ShortCut and scAlt <> 0 then Include(shift,ssAlt); if ShortCut and scCtrl <> 0 then Include(shift,ssCtrl); end; initialization DesignerMenuItemClick:=nil; ActivePopupMenu:=nil; CommandPool := nil; finalization FreeThenNil(CommandPool); end. { $Log$ Revision 1.51 2003/09/18 09:21:03 mattias renamed LCLLinux to LCLIntf Revision 1.50 2003/07/21 23:43:32 marc * Fixed radiogroup menuitems Revision 1.49 2003/06/26 17:00:00 mattias fixed result on searching proc in interface Revision 1.48 2003/06/24 15:57:55 mattias applied win32 menu patch from Micha Nelissen Revision 1.47 2003/06/24 15:23:10 mattias deleted unused code Revision 1.46 2003/06/23 12:33:55 mattias implemented TPairSplitter streaming Revision 1.45 2003/06/23 09:42:09 mattias fixes for debugging lazarus Revision 1.44 2003/06/09 09:20:27 mattias removed menubar.inc Revision 1.43 2003/05/12 13:40:50 mattias fixed clsing popupmenu on showmodal Revision 1.42 2003/05/02 22:22:15 mattias localization, added context policy to make resource string dialog Revision 1.41 2003/04/19 18:37:58 mattias implemented adding OnClick, when clicking on designer menuitem Revision 1.40 2003/04/04 16:35:24 mattias started package registration Revision 1.39 2003/03/16 09:41:05 mattias fixed checking menuitems Revision 1.38 2003/03/11 07:46:43 mattias more localization for gtk- and win32-interface and lcl Revision 1.37 2003/02/23 10:42:06 mattias implemented changing TMenuItem.GroupIndex at runtime Revision 1.36 2003/01/04 11:58:32 mattias added Windows menu to IDE Revision 1.35 2002/12/02 16:38:13 mattias started position highlighter Revision 1.34 2002/11/12 10:16:14 lazarus MG: fixed TMainMenu creation Revision 1.33 2002/10/26 15:15:47 lazarus MG: broke LCL<->interface circles Revision 1.32 2002/10/26 11:20:30 lazarus MG: broke some interfaces.pp circles Revision 1.31 2002/10/26 10:21:01 lazarus MG: broke actnlist <-> menus circle Revision 1.30 2002/10/24 09:37:39 lazarus MG: broke menus.pp <-> controls.pp circle Revision 1.29 2002/10/20 21:49:09 lazarus MG: fixes for fpc1.1 Revision 1.28 2002/10/08 22:32:26 lazarus MG: fixed cool little bug (menu double attaching bug) Revision 1.27 2002/09/19 16:45:54 lazarus MG: fixed Menu.Free and gdkwindow=nil bug Revision 1.26 2002/08/22 13:45:57 lazarus MG: fixed non AutoCheck menuitems and editor bookmark popupmenu Revision 1.25 2002/08/17 07:57:05 lazarus MG: added TPopupMenu.OnPopup and SourceEditor PopupMenu checks Revision 1.24 2002/08/16 20:13:09 lazarus MG: custom external tools are now shown in the menu Revision 1.23 2002/08/15 13:37:57 lazarus MG: started menuitem icon, checked, radio and groupindex Revision 1.22 2002/08/12 15:32:28 lazarus MG: started enhanced menuitem Revision 1.21 2002/08/08 17:26:37 lazarus MG: added property TMenuItems.RightJustify Revision 1.20 2002/08/08 10:33:49 lazarus MG: main bar speedbar open arrow now shows recent projects and files Revision 1.19 2002/08/08 09:07:06 lazarus MG: TMenuItem can now be created/destroyed/moved at any time Revision 1.18 2002/08/07 09:55:30 lazarus MG: codecompletion now checks for filebreaks, savefile now checks for filedate Revision 1.17 2002/08/06 20:05:38 lazarus MG: added stored funcitons 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 Revision 1.14 2002/08/05 08:56:56 lazarus MG: TMenuItems can now be enabled and disabled Revision 1.13 2002/05/30 21:33:10 lazarus + added / fixed streaming functions for TMenu & TMenuItem, stoppok Revision 1.12 2002/05/19 08:28:50 lazarus + added helper functions to enable streaming of TMenu / TMenuItem stoppok Revision 1.11 2002/05/15 05:58:17 lazarus MG: added TMainMenu.Parent Revision 1.10 2002/05/10 06:05:50 lazarus MG: changed license to LGPL Revision 1.9 2002/05/09 12:41:28 lazarus MG: further clientrect bugfixes Revision 1.8 2002/03/25 17:59:19 lazarus GTK Cleanup Shane Revision 1.7 2002/02/20 23:33:24 lazarus MWE: + Published OnClick for TMenuItem + Published PopupMenu property for TEdit and TMemo (Doesn't work yet) * Fixed debugger running twice + Added Debugger output form * Enabled breakpoints Revision 1.6 2002/02/18 22:46:11 lazarus Implented TMenuItem.ShortCut (not much tested). Revision 1.5 2001/06/14 14:57:58 lazarus MG: small bugfixes and less notes Revision 1.4 2000/12/29 17:50:53 lazarus Added a dropdown image to the resource and a downarrow button by the OPEN button. Shane Revision 1.3 2000/12/22 19:55:37 lazarus Added the Popupmenu code to the LCL. Now you can right click on the editor and a PopupMenu appears. Shane Revision 1.2 2000/09/10 23:08:30 lazarus MWE: + Added CreateCompatibeleBitamp function + Updated TWinControl.WMPaint + Added some checks to avoid gtk/gdk errors - Removed no fixed warning from GetDC - Removed some output Revision 1.1 2000/07/13 10:28:24 michael + Initial import Revision 1.14 2000/02/22 21:51:40 lazarus MWE: Removed some double (or triple) event declarations. The latest compiler doesn't like it Revision 1.13 1999/12/20 21:37:12 lazarus Added ISRIGHTTOLEFT in menus file. Added ISACCEL in forms.pp Shane Revision 1.12 1999/12/14 22:21:11 lazarus *** empty log message *** Revision 1.11 1999/12/08 00:56:07 lazarus MWE: Fixed menus. Events aren't enabled yet (dumps --> invalid typecast ??) Revision 1.10 1999/11/05 00:34:11 lazarus MWE: Menu structure updated, events and visible code not added yet Revision 1.9 1999/11/02 16:02:34 lazarus Added a bunch of wndproc stuff and a lot of functions that really don't do a thing at this point. Shane Revision 1.8 1999/10/28 23:48:57 lazarus MWE: Added new menu classes and started to use handleneeded }