LCL: first try at implementing TMenuItem.AutoLineReduction. Based upon patch by Artem Izmaylov, modified by me.

This commit is contained in:
Bart 2024-08-31 13:23:05 +02:00
parent e1d376486e
commit e762d9b696
3 changed files with 131 additions and 0 deletions

View File

@ -22,6 +22,7 @@
constructor TMenu.Create(AOwner: TComponent); constructor TMenu.Create(AOwner: TComponent);
begin begin
FItems := TMenuItem.Create(Self); FItems := TMenuItem.Create(Self);
FItems.FAutoLineReduction := maAutomatic;
FItems.FOnChange := @MenuChanged; FItems.FOnChange := @MenuChanged;
FItems.FMenu := Self; FItems.FMenu := Self;
FImageChangeLink := TChangeLink.Create; FImageChangeLink := TChangeLink.Create;
@ -93,6 +94,14 @@ begin
FItems.UpdateImages; FItems.UpdateImages;
end; end;
function TMenu.GetAutoLineReduction: TMenuAutoFlag;
begin
case FItems.AutoLineReduction of
maParent, maAutomatic: Result := maAutomatic; //cannot return maParent for TMenu.AutoLineReduction
maManual: Result := maManual;
end;
end;
procedure TMenu.BidiModeChanged; procedure TMenu.BidiModeChanged;
begin begin
if HandleAllocated then if HandleAllocated then
@ -140,6 +149,11 @@ begin
if Sender = Images then UpdateItems; if Sender = Images then UpdateItems;
end; end;
procedure TMenu.SetAutoLineReduction(AValue: TMenuAutoFlag);
begin
FItems.AutoLineReduction := AValue;
end;
{------------------------------------------------------------------------------ {------------------------------------------------------------------------------
Method: TMenu.CreateHandle Method: TMenu.CreateHandle
Params: None Params: None

View File

@ -115,6 +115,7 @@ begin
FRightJustify := False; FRightJustify := False;
FShowAlwaysCheckable := False; FShowAlwaysCheckable := False;
FGlyphShowMode := gsmApplication; FGlyphShowMode := gsmApplication;
FAutoLineReduction := maParent;
FImageChangeLink := TChangeLink.Create; FImageChangeLink := TChangeLink.Create;
FImageChangeLink.OnChange := @ImageListChange; FImageChangeLink.OnChange := @ImageListChange;
@ -342,6 +343,69 @@ begin
end; end;
end; end;
function TMenuItem.InternalRethinkLines(AForced: Boolean): Boolean;
var
LItem: TMenuItem;
LLastVisibleIsLine, HideSeps: Boolean;
LLastVisibleItem: TMenuItem;
I: Integer;
begin
debugln(['TMenuItem.InternalRethinkLines, AForced=',AForced]);
Result := False;
if (csDesigning in ComponentState) then
Exit;
HideSeps := GetAutoLineReduction;
if {AForced or} HideSeps then
begin
LLastVisibleIsLine := True; // to hide head line
LLastVisibleItem := nil;
for I:= 0 to Count - 1 do
begin
LItem := Items[I];
if LItem.IsLine then
begin
// hide head or double lines
if LItem.Visible <> not LLastVisibleIsLine then
begin
LItem.Visible := not LLastVisibleIsLine;
Result := True;
debugln(['TMenuItem.InternalRethinkLines: hiding separator with name "',LItem.Name,'"']);
end;
end;
if LItem.Visible then
begin
LLastVisibleIsLine := LItem.IsLine;
LLastVisibleItem := LItem;
end;
end;
// hide end line
if (LLastVisibleItem <> nil) and
LLastVisibleItem.IsLine and LLastVisibleItem.Visible then
begin
LLastVisibleItem.Visible := False;
Result := True;
debugln(['TMenuItem.InternalRethinkLines: hiding separator with name "',LItem.Name,'"']);
end;
end
else
//apparently if GetAToLineReduction is False, Delphi sets all separators to be visible
begin
for i := 0 to Count - 1 do
begin
LItem := Items[i];
if LItem.IsLine and not LItem.Visible then
begin
LItem.Visible := True;
Result := True;
debugln(['TMenuItem.InternalRethinkLines: unhiding separator with name "',LItem.Name,'"']);
end;
end;
end;
end;
procedure TMenuItem.CheckChildrenHandles; procedure TMenuItem.CheckChildrenHandles;
function GetMenu(Item: TMenuItem): TMenu; function GetMenu(Item: TMenuItem): TMenu;
@ -370,6 +434,14 @@ begin
if FItems = nil then if FItems = nil then
Exit; Exit;
InitiateActions; // actions may update items visibility
if InternalRethinkLines(False) then
begin
// Especially to re-index the items in native way
for i := 0 to Count - 1 do
Items[I].DestroyHandle;
end;
AMenu := GetMenu(Self); AMenu := GetMenu(Self);
AMergedItems := MergedItems; AMergedItems := MergedItems;
for i := 0 to AMergedItems.InvisibleCount-1 do for i := 0 to AMergedItems.InvisibleCount-1 do
@ -691,6 +763,15 @@ begin
RecreateHandle; RecreateHandle;
end; end;
procedure TMenuItem.SetAutoLineReduction(AValue: TMenuItemAutoFlag);
begin
if FAutoLineReduction <> AValue then
begin
FAutoLineReduction := AValue;
MenuChanged(True);
end;
end;
{------------------------------------------------------------------------------ {------------------------------------------------------------------------------
Function: TMenuItem.GetParentMenu Function: TMenuItem.GetParentMenu
Params: none Params: none
@ -1053,6 +1134,13 @@ begin
end; end;
end; end;
function TMenuItem.RethinkLines: Boolean;
begin
Result := InternalRethinkLines(True);
if Result then
MenuChanged(True);
end;
procedure TMenuItem.RemoveAllHandlersOfObject(AnObject: TObject); procedure TMenuItem.RemoveAllHandlersOfObject(AnObject: TObject);
var var
HandlerType: TMenuItemHandlerType; HandlerType: TMenuItemHandlerType;
@ -1673,4 +1761,20 @@ begin
UpdateImage; UpdateImage;
end; end;
function TMenuItem.GetAutoLineReduction: Boolean;
var
AutoFlag: TMenuItemAutoFlag;
begin
AutoFlag := FAutoLineReduction;
if (AutoFlag = maParent) and Assigned(Parent) then
if Parent.GetAutoLineReduction then
AutoFlag := maAutomatic
else
AutoFlag := maManual;
case AutoFlag of
maParent, maAutomatic: Result := True;
maManual: Result := False;
end;
end;
// included by menus.pp // included by menus.pp

View File

@ -59,6 +59,8 @@ type
TMenuChangeEvent = procedure (Sender: TObject; Source: TMenuItem; TMenuChangeEvent = procedure (Sender: TObject; Source: TMenuItem;
Rebuild: Boolean) of object; Rebuild: Boolean) of object;
TMenuItemAutoFlag = (maAutomatic, maManual, maParent);
TMenuAutoFlag = maAutomatic..maManual;
{ TMenuActionLink } { TMenuActionLink }
@ -147,6 +149,7 @@ type
TMenuItem = class(TLCLComponent) TMenuItem = class(TLCLComponent)
private private
FActionLink: TMenuActionLink; FActionLink: TMenuActionLink;
FAutoLineReduction: TMenuItemAutoFlag;
FCaption: TTranslateString; FCaption: TTranslateString;
FBitmap: TBitmap; FBitmap: TBitmap;
FGlyphShowMode: TGlyphShowMode; FGlyphShowMode: TGlyphShowMode;
@ -200,6 +203,7 @@ type
function IsVisibleStored: boolean; function IsVisibleStored: boolean;
procedure MergeWith(const aMenu: TMenuItem); procedure MergeWith(const aMenu: TMenuItem);
procedure SetAutoCheck(const AValue: boolean); procedure SetAutoCheck(const AValue: boolean);
procedure SetAutoLineReduction(AValue: TMenuItemAutoFlag);
procedure SetCaption(const AValue: TTranslateString); procedure SetCaption(const AValue: TTranslateString);
procedure SetChecked(AValue: Boolean); procedure SetChecked(AValue: Boolean);
procedure SetDefault(AValue: Boolean); procedure SetDefault(AValue: Boolean);
@ -222,9 +226,11 @@ type
class procedure WSRegisterClass; override; class procedure WSRegisterClass; override;
procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); virtual; procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); virtual;
procedure AssignTo(Dest: TPersistent); override; procedure AssignTo(Dest: TPersistent); override;
function GetAutoLineReduction: Boolean;
procedure BitmapChange(Sender: TObject); procedure BitmapChange(Sender: TObject);
function DoDrawItem(ACanvas: TCanvas; ARect: TRect; AState: TOwnerDrawState): Boolean; virtual; function DoDrawItem(ACanvas: TCanvas; ARect: TRect; AState: TOwnerDrawState): Boolean; virtual;
function DoMeasureItem(ACanvas: TCanvas; var AWidth, AHeight: Integer): Boolean; virtual; function DoMeasureItem(ACanvas: TCanvas; var AWidth, AHeight: Integer): Boolean; virtual;
function InternalRethinkLines(AForced: Boolean): Boolean; virtual;
function GetAction: TBasicAction; function GetAction: TBasicAction;
function GetActionLinkClass: TMenuActionLinkClass; virtual; function GetActionLinkClass: TMenuActionLinkClass; virtual;
function GetHandle: HMenu; function GetHandle: HMenu;
@ -287,6 +293,7 @@ type
procedure Clear; procedure Clear;
function HasBitmap: boolean; function HasBitmap: boolean;
function GetIconSize(ADC: HDC; DPI: Integer = 0): TPoint; virtual; function GetIconSize(ADC: HDC; DPI: Integer = 0): TPoint; virtual;
function RethinkLines: Boolean;
// Event lists // Event lists
procedure RemoveAllHandlersOfObject(AnObject: TObject); override; procedure RemoveAllHandlersOfObject(AnObject: TObject); override;
procedure AddHandlerOnDestroy(const OnDestroyEvent: TNotifyEvent; procedure AddHandlerOnDestroy(const OnDestroyEvent: TNotifyEvent;
@ -313,6 +320,8 @@ type
published published
property Action: TBasicAction read GetAction write SetAction; property Action: TBasicAction read GetAction write SetAction;
property AutoCheck: boolean read FAutoCheck write SetAutoCheck default False; property AutoCheck: boolean read FAutoCheck write SetAutoCheck default False;
property AutoLineReduction: TMenuItemAutoFlag
read FAutoLineReduction write SetAutoLineReduction default maParent;
property Caption: TTranslateString read FCaption write SetCaption property Caption: TTranslateString read FCaption write SetCaption
stored IsCaptionStored; stored IsCaptionStored;
property Checked: Boolean read FChecked write SetChecked property Checked: Boolean read FChecked write SetChecked
@ -367,8 +376,10 @@ type
//See TCustomForm.CMBiDiModeChanged //See TCustomForm.CMBiDiModeChanged
procedure CMParentBiDiModeChanged(var Message: TLMessage); message CM_PARENTBIDIMODECHANGED; procedure CMParentBiDiModeChanged(var Message: TLMessage); message CM_PARENTBIDIMODECHANGED;
procedure CMAppShowMenuGlyphChanged(var Message: TLMessage); message CM_APPSHOWMENUGLYPHCHANGED; procedure CMAppShowMenuGlyphChanged(var Message: TLMessage); message CM_APPSHOWMENUGLYPHCHANGED;
function GetAutoLineReduction: TMenuAutoFlag;
function IsBiDiModeStored: Boolean; function IsBiDiModeStored: Boolean;
procedure ImageListChange(Sender: TObject); procedure ImageListChange(Sender: TObject);
procedure SetAutoLineReduction(AValue: TMenuAutoFlag);
procedure SetBiDiMode(const AValue: TBiDiMode); procedure SetBiDiMode(const AValue: TBiDiMode);
procedure SetImages(const AValue: TCustomImageList); procedure SetImages(const AValue: TCustomImageList);
procedure SetImagesWidth(const aImagesWidth: Integer); procedure SetImagesWidth(const aImagesWidth: Integer);
@ -411,6 +422,8 @@ type
property Parent: TComponent read FParent write SetParent; property Parent: TComponent read FParent write SetParent;
property ShortcutHandled: boolean read FShortcutHandled write FShortcutHandled; property ShortcutHandled: boolean read FShortcutHandled write FShortcutHandled;
published published
property AutoLineReduction: TMenuAutoFlag
read GetAutoLineReduction write SetAutoLineReduction default maAutomatic;
property BidiMode:TBidiMode read FBidiMode write SetBidiMode stored IsBiDiModeStored default bdLeftToRight; property BidiMode:TBidiMode read FBidiMode write SetBidiMode stored IsBiDiModeStored default bdLeftToRight;
property ParentBidiMode:Boolean read FParentBidiMode write SetParentBidiMode default True; property ParentBidiMode:Boolean read FParentBidiMode write SetParentBidiMode default True;
property Items: TMenuItem read FItems; property Items: TMenuItem read FItems;