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

LCL: menus: implement StripHotkey (Delphi compatibilty)

Browse Source 
git-svn-id: trunk@52307 -
This commit is contained in:
ondrej 2016-05-15 09:26:48 +00:00
parent 2b94ec1a7c
commit 5b3cd06ae3
1 changed files with 29 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

29
lcl/menus.pp
View File

@ -447,6 +447,7 @@ function NewItem(const ACaption: string; AShortCut: TShortCut;
hCtx: THelpContext; const AName: string): TMenuItem; hCtx: THelpContext; const AName: string): TMenuItem;
function NewLine: TMenuItem; function NewLine: TMenuItem;
function StripHotkey(const Text: string): string;
procedure Register; procedure Register;
@ -545,6 +546,34 @@ begin
Result.Caption := cLineCaption; Result.Caption := cLineCaption;
end; end;
function StripHotkey(const Text: string): string;
var
I, R: Integer;
begin
SetLength(Result, Length(Text));
I := 1;
R := 1;
while I <= Length(Text) do
begin
if Text[I] = cHotkeyPrefix then
begin
if (I < Length(Text)) and (Text[I+1] = cHotkeyPrefix) then
begin
Result[R] := Text[I];
Inc(R);
Inc(I, 2);
end else
Inc(I);
end else
begin
Result[R] := Text[I];
Inc(R);
Inc(I);
end;
end;
SetLength(Result, R-1);
end;
procedure Register; procedure Register;
begin begin
RegisterComponents('Standard',[TMainMenu,TPopupMenu]); RegisterComponents('Standard',[TMainMenu,TPopupMenu]);