paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-05-21 00:03:28 +02:00
Code Issues Packages Projects Releases Wiki Activity

MG: added actnlist.pp

Browse Source 
git-svn-id: trunk@1824 -
This commit is contained in:
lazarus 2002-08-06 19:57:40 +00:00
parent 0c9f57bd32
commit 52650eac79
11 changed files with 1343 additions and 4 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
.gitattributes vendored
View File

@ -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

340
lcl/actnlist.pas Normal file
View File

@ -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.

6
lcl/imglist.pp
View File

@ -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

24
lcl/include/action.inc Normal file
View File

@ -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

131
lcl/include/actionlink.inc Normal file
View File

@ -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

128
lcl/include/containedaction.inc Normal file
View File

@ -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

337
lcl/include/customaction.inc Normal file
View File

@ -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

147
lcl/include/menuactionlink.inc Normal file
View File

@ -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

16
lcl/include/menuitem.inc
View File

@ -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

48
lcl/include/shortcutlist.inc Normal file
View File

@ -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

163
lcl/menus.pp
View File

@ -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