\n\n
in D2007 TOPopupMenu = class(TTntPopupMenu), TOMenuItem = class(TTntMenuItem)\nin DXE2 TOPopupMenu = class(TPopupMenu), TOMenuItem = class(TMenuItem)\n
\n\nDelphi 2007:
\nhttp://s15.postimage.org/rzd4sc8pn/delphi_menu.png
Unit OMenus_Editors which works in Delphi 2007 (basically copied from TntUnicodeControls)
\n\n{*****************************************************************************}\n{ }\n{ Tnt Delphi Unicode Controls }\n{ http://www.tntware.com/delphicontrols/unicode/ }\n{ Version: 2.3.0 }\n{ }\n{ Copyright (c) 2002-2007, Troy Wolbrink (troy.wolbrink@tntware.com) }\n{ }\n{*****************************************************************************}\n\nunit OMenus_Editors;\n\n{$INCLUDE ..\\TntUnicodeControls\\Source\\TntCompilers.inc}\n\n{*******************************************************}\n{ Special Thanks to Francisco Leong for getting these }\n{ menu designer enhancements to work w/o MnuBuild. }\n{*******************************************************}\n\ninterface\n\n{$IFDEF COMPILER_6} // Delphi 6 and BCB 6 have MnuBuild available\n {$DEFINE MNUBUILD_AVAILABLE}\n{$ENDIF}\n\n{$IFDEF COMPILER_7} // Delphi 7 has MnuBuild available\n {$DEFINE MNUBUILD_AVAILABLE}\n{$ENDIF}\n\nuses\n Windows, Classes, Menus, Messages,\n {$IFDEF MNUBUILD_AVAILABLE} MnuBuild, {$ENDIF}\n DesignEditors, DesignIntf;\n\ntype\n TOMenuEditor = class(TComponentEditor)\n public\n procedure ExecuteVerb(Index: Integer); override;\n function GetVerb(Index: Integer): string{TNT-ALLOW string}; override;\n function GetVerbCount: Integer; override;\n end;\n\nprocedure Register;\n\nimplementation\n\nuses\n {$IFDEF MNUBUILD_AVAILABLE} MnuConst, {$ELSE} DesignWindows, {$ENDIF} SysUtils, Graphics, ActnList,\n Controls, Forms, TntDesignEditors_Design, TntActnList, TntMenus, OPopupMenu;\n\nprocedure Register;\nbegin\n //RegisterComponentEditor(TMainMenu, TOMenuEditor);\n RegisterComponentEditor(TOPopupMenu, TOMenuEditor);\nend;\n\nfunction GetMenuBuilder: TForm{TNT-ALLOW TForm};\n{$IFDEF MNUBUILD_AVAILABLE}\nbegin\n Result := MenuEditor;\n{$ELSE}\nvar\n Comp: TComponent;\nbegin\n Result := nil;\n if Application <> nil then\n begin\n Comp := Application.FindComponent('MenuBuilder');\n if Comp is TForm{TNT-ALLOW TForm} then\n Result := TForm{TNT-ALLOW TForm}(Comp);\n end;\n{$ENDIF}\nend;\n\n{$IFDEF DELPHI_9} // verified against Delphi 9\ntype\n THackMenuBuilder = class(TDesignWindow)\n protected\n Fields: array[1..26] of TObject;\n FWorkMenu: TMenuItem{TNT-ALLOW TMenuItem};\n end;\n{$ENDIF}\n\n{$IFDEF COMPILER_10_UP}\n{$IFDEF DELPHI_10} // NOT verified against Delphi 10\ntype\n THackMenuBuilder = class(TDesignWindow)\n protected\n Fields: array[1..26] of TObject;\n FWorkMenu: TMenuItem{TNT-ALLOW TMenuItem};\n end;\n{$ENDIF}\n{$ENDIF}\n\nfunction GetMenuBuilder_WorkMenu(MenuBuilder: TForm{TNT-ALLOW TForm}): TMenuItem{TNT-ALLOW TMenuItem};\nbegin\n if MenuBuilder = nil then\n Result := nil\n else begin\n {$IFDEF MNUBUILD_AVAILABLE}\n Result := MenuEditor.WorkMenu;\n {$ELSE}\n Result := THackMenuBuilder(MenuBuilder).FWorkMenu;\n Assert((Result = nil) or (Result is TMenuItem{TNT-ALLOW TMenuItem}),\n 'TNT Internal Error: THackMenuBuilder has incorrect internal layout.');\n {$ENDIF}\n end;\nend;\n\n{$IFDEF DELPHI_9} // verified against Delphi 9\ntype\n THackMenuItemWin = class(TCustomControl)\n protected\n FxxxxCaptionExtent: Integer;\n FMenuItem: TMenuItem{TNT-ALLOW TMenuItem};\n end;\n{$ENDIF}\n\n{$IFDEF DELPHI_10} // beta: NOT verified against Delphi 10\ntype\n THackMenuItemWin = class(TCustomControl)\n protected\n FxxxxCaptionExtent: Integer;\n FMenuItem: TMenuItem{TNT-ALLOW TMenuItem};\n end;\n{$ENDIF}\n\nfunction GetMenuItem(Control: TWinControl; DoVerify: Boolean = True): TMenuItem{TNT-ALLOW TMenuItem};\nbegin\n {$IFDEF MNUBUILD_AVAILABLE}\n if Control is TMenuItemWin then\n Result := TMenuItemWin(Control).MenuItem\n {$ELSE}\n if Control.ClassName = 'TMenuItemWin' then begin\n Result := THackMenuItemWin(Control).FMenuItem;\n Assert((Result = nil) or (Result is TMenuItem{TNT-ALLOW TMenuItem}), 'TNT Internal Error: Unexpected TMenuItem field layout.');\n end\n {$ENDIF}\n else if DoVerify then\n raise Exception.Create('TNT Internal Error: Control is not a TMenuItemWin.')\n else\n Result := nil;\nend;\n\nprocedure SetMenuItem(Control: TWinControl; Item: TMenuItem{TNT-ALLOW TMenuItem});\nbegin\n {$IFDEF MNUBUILD_AVAILABLE}\n if Control is TMenuItemWin then\n TMenuItemWin(Control).MenuItem := Item\n {$ELSE}\n if Control.ClassName = 'TMenuItemWin' then begin\n THackMenuItemWin(Control).FMenuItem := Item;\n Item.FreeNotification(Control);\n end\n {$ENDIF}\n else\n raise Exception.Create('TNT Internal Error: Control is not a TMenuItemWin.');\nend;\n\nprocedure ReplaceMenuItem(Control: TWinControl; ANewItem: TMenuItem{TNT-ALLOW TMenuItem});\nvar\n OldItem: TMenuItem{TNT-ALLOW TMenuItem};\n OldName: string{TNT-ALLOW string};\nbegin\n OldItem := GetMenuItem(Control, True);\n Assert(OldItem <> nil);\n OldName := OldItem.Name;\n FreeAndNil(OldItem);\n ANewItem.Name := OldName; { assume old name }\n SetMenuItem(Control, ANewItem);\nend;\n\n{ TTntMenuBuilderChecker }\n\ntype\n TMenuBuilderChecker = class(TComponent)\n private\n FMenuBuilder: TForm{TNT-ALLOW TForm};\n FCheckMenuAction: TTntAction;\n FLastCaption: string{TNT-ALLOW string};\n FLastActiveControl: TControl;\n FLastMenuItem: TMenuItem{TNT-ALLOW TMenuItem};\n procedure CheckMenuItems(Sender: TObject);\n public\n constructor Create(AOwner: TComponent); override;\n destructor Destroy; override;\n end;\n\nvar MenuBuilderChecker: TMenuBuilderChecker = nil;\n\nconstructor TMenuBuilderChecker.Create(AOwner: TComponent);\nbegin\n inherited;\n MenuBuilderChecker := Self;\n FCheckMenuAction := TTntAction.Create(Self);\n FCheckMenuAction.OnUpdate := CheckMenuItems;\n FCheckMenuAction.OnExecute := CheckMenuItems;\n FMenuBuilder := AOwner as TForm{TNT-ALLOW TForm};\n FMenuBuilder.Action := FCheckMenuAction;\nend;\n\ndestructor TMenuBuilderChecker.Destroy;\nbegin\n FMenuBuilder := nil;\n MenuBuilderChecker := nil;\n inherited;\nend;\n\ntype TAccessOMenuItem = class(TOMenuItem);\n\nfunction CreateOMenuItem(OldItem: TMenuItem{TNT-ALLOW TMenuItem}): TOMenuItem;\nvar\n OldName: AnsiString;\n OldParent: TMenuItem{TNT-ALLOW TMenuItem};\n OldIndex: Integer;\n OldItemsList: TList;\n j: integer;\nbegin\n // item should be converted.\n OldItemsList := TList.Create;\n try\n // clone properties\n Result := TOMenuItem.Create(OldItem.Owner);\n TAccessOMenuItem(Result).FComponentStyle := OldItem.ComponentStyle; {csTransient hides item from object inspector}\n Result.Action := OldItem.Action;\n Result.AutoCheck := OldItem.AutoCheck;\n Result.AutoHotkeys := OldItem.AutoHotkeys;\n Result.AutoLineReduction := OldItem.AutoLineReduction;\n Result.Bitmap := OldItem.Bitmap;\n Result.Break := OldItem.Break;\n Result.Caption := OldItem.Caption;\n Result.Checked := OldItem.Checked;\n Result.Default := OldItem.Default;\n Result.Enabled := OldItem.Enabled;\n Result.GroupIndex := OldItem.GroupIndex;\n Result.HelpContext := OldItem.HelpContext;\n Result.Hint := OldItem.Hint;\n Result.ImageIndex := OldItem.ImageIndex;\n Result.MenuIndex := OldItem.MenuIndex;\n Result.RadioItem := OldItem.RadioItem;\n Result.ShortCut := OldItem.ShortCut;\n Result.SubMenuImages := OldItem.SubMenuImages;\n Result.Visible := OldItem.Visible;\n Result.Tag := OldItem.Tag;\n\n // clone events\n Result.OnAdvancedDrawItem := OldItem.OnAdvancedDrawItem;\n Result.OnClick := OldItem.OnClick;\n Result.OnDrawItem := OldItem.OnDrawItem;\n Result.OnMeasureItem := OldItem.OnMeasureItem;\n\n // remember name, parent, index, children\n OldName := OldItem.Name;\n OldParent := OldItem.Parent;\n OldIndex := OldItem.MenuIndex;\n for j := OldItem.Count - 1 downto 0 do begin\n OldItemsList.Insert(0, OldItem.Items[j]);\n OldItem.Remove(OldItem.Items[j]);\n end;\n\n // clone final parts of old item\n for j := 0 to OldItemsList.Count - 1 do\n Result.Add(TMenuItem{TNT-ALLOW TMenuItem}(OldItemsList[j])); { add children }\n if OldParent <> nil then\n OldParent.Insert(OldIndex, Result); { insert into parent }\n finally\n OldItemsList.Free;\n end;\nend;\n\nprocedure CheckMenuItemWin(MenuItemWin: TWinControl; PartOfATntMenu: Boolean);\nvar\n OldItem: TMenuItem{TNT-ALLOW TMenuItem};\nbegin\n OldItem := GetMenuItem(MenuItemWin);\n if OldItem = nil then\n exit;\n if (OldItem.ClassType = TMenuItem{TNT-ALLOW TMenuItem})\n and (PartOfATntMenu or (OldItem.Parent is TOMenuItem)) then\n begin\n if MenuItemWin.Focused then\n MenuItemWin.Parent.SetFocus; {Lose focus and regain later to ensure object inspector gets updated.}\n ReplaceMenuItem(MenuItemWin, CreateOMenuItem(OldItem));\n end else if (OldItem.ClassType = TOMenuItem)\n and (OldItem.Parent = nil) and (OldItem.Caption = '') and (OldItem.Name = '')\n and not (PartOfATntMenu or (OldItem.Parent is TOMenuItem)) then begin\n if MenuItemWin.Focused then\n MenuItemWin.Parent.SetFocus; {Lose focus and regain later to ensure object inspector gets updated.}\n ReplaceMenuItem(MenuItemWin, TMenuItem{TNT-ALLOW TMenuItem}.Create(OldItem.Owner));\n end;\nend;\n\nprocedure TMenuBuilderChecker.CheckMenuItems(Sender: TObject);\nvar\n a, i: integer;\n MenuWin: TWinControl;\n MenuItemWin: TWinControl;\n SaveFocus: HWND;\n PartOfATntMenu: Boolean;\n WorkMenu: TMenuItem{TNT-ALLOW TMenuItem};\nbegin\n if (FMenuBuilder <> nil)\n and (FMenuBuilder.Action = FCheckMenuAction) then begin\n if (FLastCaption <> FMenuBuilder.Caption)\n or (FLastActiveControl <> FMenuBuilder.ActiveControl)\n or (FLastMenuItem <> GetMenuItem(FMenuBuilder.ActiveControl, False))\n then begin\n try\n try\n with FMenuBuilder do begin\n WorkMenu := GetMenuBuilder_WorkMenu(FMenuBuilder);\n PartOfATntMenu := (WorkMenu <> nil)\n and ((WorkMenu.Owner is TTntMainMenu) or (WorkMenu.Owner is TTntPopupMenu));\n SaveFocus := Windows.GetFocus;\n for a := ComponentCount - 1 downto 0 do begin\n {$IFDEF MNUBUILD_AVAILABLE}\n if Components[a] is TMenuWin then begin\n {$ELSE}\n if Components[a].ClassName = 'TMenuWin' then begin\n {$ENDIF}\n MenuWin := Components[a] as TWinControl;\n with MenuWin do begin\n for i := ComponentCount - 1 downto 0 do begin\n {$IFDEF MNUBUILD_AVAILABLE}\n if Components[i] is TMenuItemWin then begin\n {$ELSE}\n if Components[i].ClassName = 'TMenuItemWin' then begin\n {$ENDIF}\n MenuItemWin := Components[i] as TWinControl;\n CheckMenuItemWin(MenuItemWin, PartOfATntMenu);\n end;\n end;\n end;\n end;\n end;\n if SaveFocus <> Windows.GetFocus then\n Windows.SetFocus(SaveFocus);\n end;\n except\n on E: Exception do begin\n FMenuBuilder.Action := nil;\n end;\n end;\n finally\n FLastCaption := FMenuBuilder.Caption;\n FLastActiveControl := FMenuBuilder.ActiveControl;\n FLastMenuItem := GetMenuItem(FMenuBuilder.ActiveControl, False);\n end;\n end;\n end;\nend;\n\n{ TOMenuEditor }\n\nfunction TOMenuEditor.GetVerbCount: Integer;\nbegin\n Result := 1;\nend;\n\n{$IFNDEF MNUBUILD_AVAILABLE}\nresourcestring\n SMenuDesigner = 'Menu Designer...';\n{$ENDIF}\n\nfunction TOMenuEditor.GetVerb(Index: Integer): string{TNT-ALLOW string};\nbegin\n Result := SMenuDesigner;\nend;\n\nprocedure TOMenuEditor.ExecuteVerb(Index: Integer);\nvar\n MenuBuilder: TForm{TNT-ALLOW TForm};\nbegin\n EditPropertyWithDialog(Component, 'Items', Designer);\n MenuBuilder := GetMenuBuilder;\n if Assigned(MenuBuilder) then begin\n if (MenuBuilderChecker = nil) or (MenuBuilderChecker.FMenuBuilder <> MenuBuilder) then begin\n MenuBuilderChecker.Free;\n MenuBuilderChecker := TMenuBuilderChecker.Create(MenuBuilder);\n end;\n EditPropertyWithDialog(Component, 'Items', Designer); // update menu builder caption\n end;\nend;\n\ninitialization\n\nfinalization\n if Assigned(MenuBuilderChecker) then\n FreeAndNil(MenuBuilderChecker); // design package might be recompiled\n\nend.\n
\n","author":{"@type":"Person","name":"oxo"},"upvoteCount":1,"answerCount":1,"acceptedAnswer":{"@type":"Answer","text":"I figured it out. The problem was in THackMenuBuilder. This code works for both D2007 and DXE2.
\n\nMaybe somebody finds it useful if he writes custom menus.
\n\nOMenus_Editors.pas:
\n\n{*****************************************************************************}\n{ }\n{ Modified by oxo (http://www.kluug.at) }\n{ }\n{ Original Code (TntMenus_Editors.pas) }\n{ }\n{ Tnt Delphi Unicode Controls }\n{ http://www.tntware.com/delphicontrols/unicode/ }\n{ Version: 2.3.0 }\n{ }\n{ Copyright (c) 2002-2007, Troy Wolbrink (troy.wolbrink@tntware.com) }\n{ }\n{*****************************************************************************}\n\nunit OMenus_Editors;\n\n{*******************************************************}\n{ Special Thanks to Francisco Leong for getting these }\n{ menu designer enhancements to work w/o MnuBuild. }\n{*******************************************************}\n\ninterface\n\n{$IFDEF VER150}//Delphi 7\n {$DEFINE MNUBUILD_AVAILABLE}\n{$ENDIF}\n{$IFDEF VER140}//Delphi 6\n {$DEFINE MNUBUILD_AVAILABLE}\n{$ENDIF}\n\nuses\n Windows, Classes, Menus, Messages,\n {$IFDEF MNUBUILD_AVAILABLE} MnuBuild, {$ENDIF}\n DesignEditors, DesignIntf;\n\ntype\n TOMenuEditor = class(TComponentEditor)\n public\n procedure ExecuteVerb(Index: Integer); override;\n function GetVerb(Index: Integer): string; override;\n function GetVerbCount: Integer; override;\n end;\n\nprocedure Register;\n\nimplementation\n\nuses\n {$IFDEF MNUBUILD_AVAILABLE} MnuConst, {$ELSE} DesignWindows, {$ENDIF} SysUtils, Graphics, ActnList,\n Controls, Forms, OPopupMenu, ODesignEditors_Design, Dialogs;\n\nprocedure Register;\nbegin\n RegisterComponentEditor(TOPopupMenu, TOMenuEditor);\nend;\n\nfunction GetMenuBuilder: TCustomForm;\n{$IFDEF MNUBUILD_AVAILABLE}\nbegin\n Result := MenuEditor;\n{$ELSE}\nvar\n Comp: TComponent;\nbegin\n Result := nil;\n if Application <> nil then\n begin\n Comp := Application.FindComponent('MenuBuilder');\n if Comp is TCustomForm then begin\n Result := TCustomForm(Comp);\n end;\n end;\n{$ENDIF}\nend;\n\ntype\n THackMenuBuilder = class(TDesignWindow)\n protected\n Fields: array[0..49] of TObject;\n end;\n\nfunction GetMenuBuilder_WorkMenu(MenuBuilder: TCustomForm): TMenuItem;\nvar I: Integer;\nbegin\n if MenuBuilder = nil then\n Result := nil\n else begin\n {$IFDEF MNUBUILD_AVAILABLE}\n Result := MenuEditor.WorkMenu;\n {$ELSE}\n Result := nil;\n for I := 25 to 35 do begin\n try\n if THackMenuBuilder(MenuBuilder).Fields[I] is TMenuItem then\n Result := TMenuItem(THackMenuBuilder(MenuBuilder).Fields[I]);\n except\n end;\n end;\n\n Assert((Result = nil) or (Result is TMenuItem),\n 'OMenus Internal Error: THackMenuBuilder has incorrect internal layout.');\n {$ENDIF}\n end;\nend;\n\ntype\n THackMenuItemWin = class(TCustomControl)\n protected\n FxxxxCaptionExtent: Integer;\n FMenuItem: TMenuItem;\n end;\n\nfunction GetMenuItem(Control: TWinControl; DoVerify: Boolean = True): TMenuItem;\nbegin\n {$IFDEF MNUBUILD_AVAILABLE}\n if Control is TMenuItemWin then\n Result := TMenuItemWin(Control).MenuItem\n {$ELSE}\n if Control.ClassName = 'TMenuItemWin' then begin\n Result := THackMenuItemWin(Control).FMenuItem;\n Assert((Result = nil) or (Result is TMenuItem), 'OMenus Internal Error: Unexpected TMenuItem field layout.');\n end\n {$ENDIF}\n else if DoVerify then\n raise Exception.Create('OMenus Internal Error: Control is not a TMenuItemWin.')\n else\n Result := nil;\nend;\n\nprocedure SetMenuItem(Control: TWinControl; Item: TMenuItem);\nbegin\n {$IFDEF MNUBUILD_AVAILABLE}\n if Control is TMenuItemWin then\n TMenuItemWin(Control).MenuItem := Item\n {$ELSE}\n if Control.ClassName = 'TMenuItemWin' then begin\n THackMenuItemWin(Control).FMenuItem := Item;\n Item.FreeNotification(Control);\n end\n {$ENDIF}\n else\n raise Exception.Create('OMenus Internal Error: Control is not a TMenuItemWin.');\nend;\n\nprocedure ReplaceMenuItem(Control: TWinControl; ANewItem: TMenuItem);\nvar\n OldItem: TMenuItem;\n OldName: string;\nbegin\n OldItem := GetMenuItem(Control, True);\n Assert(OldItem <> nil);\n OldName := OldItem.Name;\n FreeAndNil(OldItem);\n ANewItem.Name := OldName; { assume old name }\n SetMenuItem(Control, ANewItem);\nend;\n\n{ TMenuBuilderChecker }\n\ntype\n TMenuBuilderChecker = class(TComponent)\n private\n FMenuBuilder: TCustomForm;\n FCheckMenuAction: TAction;\n FLastCaption: string;\n FLastActiveControl: TControl;\n FLastMenuItem: TMenuItem;\n procedure CheckMenuItems(Sender: TObject);\n public\n constructor Create(AOwner: TComponent); override;\n destructor Destroy; override;\n end;\n\nvar MenuBuilderChecker: TMenuBuilderChecker = nil;\n\nconstructor TMenuBuilderChecker.Create(AOwner: TComponent);\nbegin\n inherited;\n MenuBuilderChecker := Self;\n FCheckMenuAction := TAction.Create(Self);\n FCheckMenuAction.OnUpdate := CheckMenuItems;\n FCheckMenuAction.OnExecute := CheckMenuItems;\n FMenuBuilder := AOwner as TCustomForm;\n FMenuBuilder.Action := FCheckMenuAction;\nend;\n\ndestructor TMenuBuilderChecker.Destroy;\nbegin\n FMenuBuilder := nil;\n MenuBuilderChecker := nil;\n inherited;\nend;\n\ntype TAccessOMenuItem = class(TOMenuItem);\n\nfunction CreateOMenuItem(OldItem: TMenuItem): TOMenuItem;\nvar\n OldName: AnsiString;\n OldParent: TMenuItem;\n OldIndex: Integer;\n OldItemsList: TList;\n j: integer;\nbegin\n // item should be converted.\n OldItemsList := TList.Create;\n try\n // clone properties\n Result := TOMenuItem.Create(OldItem.Owner);\n TAccessOMenuItem(Result).FComponentStyle := OldItem.ComponentStyle; {csTransient hides item from object inspector}\n Result.Action := OldItem.Action;\n Result.AutoCheck := OldItem.AutoCheck;\n Result.AutoHotkeys := OldItem.AutoHotkeys;\n Result.AutoLineReduction := OldItem.AutoLineReduction;\n Result.Bitmap := OldItem.Bitmap;\n Result.Break := OldItem.Break;\n Result.Caption := OldItem.Caption;\n Result.Checked := OldItem.Checked;\n Result.Default := OldItem.Default;\n Result.Enabled := OldItem.Enabled;\n Result.GroupIndex := OldItem.GroupIndex;\n Result.HelpContext := OldItem.HelpContext;\n Result.Hint := OldItem.Hint;\n Result.ImageIndex := OldItem.ImageIndex;\n Result.MenuIndex := OldItem.MenuIndex;\n Result.RadioItem := OldItem.RadioItem;\n Result.ShortCut := OldItem.ShortCut;\n Result.SubMenuImages := OldItem.SubMenuImages;\n Result.Visible := OldItem.Visible;\n Result.Tag := OldItem.Tag;\n\n // clone events\n Result.OnAdvancedDrawItem := OldItem.OnAdvancedDrawItem;\n Result.OnClick := OldItem.OnClick;\n Result.OnDrawItem := OldItem.OnDrawItem;\n Result.OnMeasureItem := OldItem.OnMeasureItem;\n\n // remember name, parent, index, children\n OldName := OldItem.Name;\n OldParent := OldItem.Parent;\n OldIndex := OldItem.MenuIndex;\n for j := OldItem.Count - 1 downto 0 do begin\n OldItemsList.Insert(0, OldItem.Items[j]);\n OldItem.Remove(OldItem.Items[j]);\n end;\n\n // clone final parts of old item\n for j := 0 to OldItemsList.Count - 1 do\n Result.Add(TMenuItem(OldItemsList[j])); { add children }\n if OldParent <> nil then\n OldParent.Insert(OldIndex, Result); { insert into parent }\n finally\n OldItemsList.Free;\n end;\nend;\n\nprocedure CheckMenuItemWin(MenuItemWin: TWinControl; PartOfAMenu: Boolean);\nvar\n OldItem: TMenuItem;\nbegin\n OldItem := GetMenuItem(MenuItemWin);\n if OldItem = nil then\n exit;\n if (OldItem.ClassType = TMenuItem)\n and (PartOfAMenu or (OldItem.Parent is TOMenuItem)) then\n begin\n if MenuItemWin.Focused then\n MenuItemWin.Parent.SetFocus; {Lose focus and regain later to ensure object inspector gets updated.}\n ReplaceMenuItem(MenuItemWin, CreateOMenuItem(OldItem));\n end else if (OldItem.ClassType = TOMenuItem)\n and (OldItem.Parent = nil) and (OldItem.Caption = '') and (OldItem.Name = '')\n and not (PartOfAMenu or (OldItem.Parent is TOMenuItem)) then begin\n if MenuItemWin.Focused then\n MenuItemWin.Parent.SetFocus; {Lose focus and regain later to ensure object inspector gets updated.}\n ReplaceMenuItem(MenuItemWin, TMenuItem.Create(OldItem.Owner));\n end;\nend;\n\nprocedure TMenuBuilderChecker.CheckMenuItems(Sender: TObject);\nvar\n a, i: integer;\n MenuWin: TWinControl;\n MenuItemWin: TWinControl;\n SaveFocus: HWND;\n PartOfAMenu: Boolean;\n WorkMenu: TMenuItem;\nbegin\n if (FMenuBuilder <> nil)\n and (FMenuBuilder.Action = FCheckMenuAction) then begin\n if (FLastCaption <> FMenuBuilder.Caption)\n or (FLastActiveControl <> FMenuBuilder.ActiveControl)\n or (FLastMenuItem <> GetMenuItem(FMenuBuilder.ActiveControl, False))\n then begin\n try\n try\n with FMenuBuilder do begin\n WorkMenu := GetMenuBuilder_WorkMenu(FMenuBuilder);\n PartOfAMenu := (WorkMenu <> nil)\n and ((WorkMenu.Owner is TMainMenu) or (WorkMenu.Owner is TPopupMenu));\n //ShowMessage('CheckMenuItems: ' + BoolToStr((WorkMenu <> nil), True));\n SaveFocus := Windows.GetFocus;\n for a := ComponentCount - 1 downto 0 do begin\n {$IFDEF MNUBUILD_AVAILABLE}\n if Components[a] is TMenuWin then begin\n {$ELSE}\n if Components[a].ClassName = 'TMenuWin' then begin\n {$ENDIF}\n MenuWin := Components[a] as TWinControl;\n with MenuWin do begin\n for i := ComponentCount - 1 downto 0 do begin\n {$IFDEF MNUBUILD_AVAILABLE}\n if Components[i] is TMenuItemWin then begin\n {$ELSE}\n if Components[i].ClassName = 'TMenuItemWin' then begin\n {$ENDIF}\n MenuItemWin := Components[i] as TWinControl;\n CheckMenuItemWin(MenuItemWin, PartOfAMenu);\n end;\n end;\n end;\n end;\n end;\n if SaveFocus <> Windows.GetFocus then\n Windows.SetFocus(SaveFocus);\n end;\n except\n on E: Exception do begin\n FMenuBuilder.Action := nil;\n end;\n end;\n finally\n FLastCaption := FMenuBuilder.Caption;\n FLastActiveControl := FMenuBuilder.ActiveControl;\n FLastMenuItem := GetMenuItem(FMenuBuilder.ActiveControl, False);\n end;\n end;\n end;\nend;\n\n{ TOMenuEditor }\n\nfunction TOMenuEditor.GetVerbCount: Integer;\nbegin\n Result := 1;\nend;\n\n{$IFNDEF MNUBUILD_AVAILABLE}\nresourcestring\n SMenuDesigner = 'Menu Designer...';\n{$ENDIF}\n\nfunction TOMenuEditor.GetVerb(Index: Integer): string;\nbegin\n Result := SMenuDesigner;\nend;\n\nprocedure TOMenuEditor.ExecuteVerb(Index: Integer);\nvar\n MenuBuilder: TCustomForm;\nbegin\n EditPropertyWithDialog(Component, 'Items', Designer);\n MenuBuilder := GetMenuBuilder;\n if Assigned(MenuBuilder) then begin\n if (MenuBuilderChecker = nil) or (MenuBuilderChecker.FMenuBuilder <> MenuBuilder) then begin\n MenuBuilderChecker.Free;\n MenuBuilderChecker := TMenuBuilderChecker.Create(MenuBuilder);\n end;\n EditPropertyWithDialog(Component, 'Items', Designer); // update menu builder caption\n end;\nend;\n\ninitialization\n\nfinalization\n if Assigned(MenuBuilderChecker) then\n FreeAndNil(MenuBuilderChecker); // design package might be recompiled\n\nend.\n
\n\nODesignEditors_Design.pas:
\n\n{*****************************************************************************}\n{ }\n{ Modified by oxo (http://www.kluug.at) }\n{ }\n{ Original Code (ODesignEditors_Design.pas) }\n{ }\n{ Tnt Delphi Unicode Controls }\n{ http://www.tntware.com/delphicontrols/unicode/ }\n{ Version: 2.3.0 }\n{ }\n{ Copyright (c) 2002-2007, Troy Wolbrink (troy.wolbrink@tntware.com) }\n{ }\n{*****************************************************************************}\n\nunit ODesignEditors_Design;\n\ninterface\n\nuses\n Classes, Forms, TypInfo, DesignIntf, DesignEditors;\n\nprocedure EditPropertyWithDialog(Component: TPersistent; const PropName: String; const Designer: IDesigner);\n\nimplementation\n\nuses\n SysUtils;\n\n{ TPropertyEditorWithDialog }\ntype\n TPropertyEditorWithDialog = class\n private\n FPropName: String;\n procedure CheckEditProperty(const Prop: IProperty);\n procedure EditProperty(Component: TPersistent; const PropName: String; const Designer: IDesigner);\n end;\n\nprocedure TPropertyEditorWithDialog.CheckEditProperty(const Prop: IProperty);\nbegin\n if Prop.GetName = FPropName then\n Prop.Edit;\nend;\n\nprocedure TPropertyEditorWithDialog.EditProperty(Component: TPersistent; const PropName: String; const Designer: IDesigner);\nvar\n Components: IDesignerSelections;\nbegin\n FPropName := PropName;\n Components := TDesignerSelections.Create;\n Components.Add(Component);\n GetComponentProperties(Components, [tkClass], Designer, CheckEditProperty);\nend;\n\nprocedure EditPropertyWithDialog(Component: TPersistent; const PropName: String; const Designer: IDesigner);\nbegin\n with TPropertyEditorWithDialog.Create do\n try\n EditProperty(Component, PropName, Designer);\n finally\n Free;\n end;\nend;\n\nend.\n
\n","author":{"@type":"Person","name":"oxo"},"upvoteCount":1}}}Reputation: 1006
I have an enhanced popup menu (TOPopupMenu) with customized items (TOMenuItem). In Delphi 2007 I used TNT's code to force the delphi design editor to create TOMenuItem in the menu editor. Unfortunately, the same approach doesn't work for me in XE2.
Does anybody know how to do this in Delphi XE2?
Note:
in D2007 TOPopupMenu = class(TTntPopupMenu), TOMenuItem = class(TTntMenuItem)
in DXE2 TOPopupMenu = class(TPopupMenu), TOMenuItem = class(TMenuItem)
Delphi 2007:
http://s15.postimage.org/rzd4sc8pn/delphi_menu.png
Unit OMenus_Editors which works in Delphi 2007 (basically copied from TntUnicodeControls)
{*****************************************************************************}
{ }
{ Tnt Delphi Unicode Controls }
{ http://www.tntware.com/delphicontrols/unicode/ }
{ Version: 2.3.0 }
{ }
{ Copyright (c) 2002-2007, Troy Wolbrink (troy.wolbrink@tntware.com) }
{ }
{*****************************************************************************}
unit OMenus_Editors;
{$INCLUDE ..\TntUnicodeControls\Source\TntCompilers.inc}
{*******************************************************}
{ Special Thanks to Francisco Leong for getting these }
{ menu designer enhancements to work w/o MnuBuild. }
{*******************************************************}
interface
{$IFDEF COMPILER_6} // Delphi 6 and BCB 6 have MnuBuild available
{$DEFINE MNUBUILD_AVAILABLE}
{$ENDIF}
{$IFDEF COMPILER_7} // Delphi 7 has MnuBuild available
{$DEFINE MNUBUILD_AVAILABLE}
{$ENDIF}
uses
Windows, Classes, Menus, Messages,
{$IFDEF MNUBUILD_AVAILABLE} MnuBuild, {$ENDIF}
DesignEditors, DesignIntf;
type
TOMenuEditor = class(TComponentEditor)
public
procedure ExecuteVerb(Index: Integer); override;
function GetVerb(Index: Integer): string{TNT-ALLOW string}; override;
function GetVerbCount: Integer; override;
end;
procedure Register;
implementation
uses
{$IFDEF MNUBUILD_AVAILABLE} MnuConst, {$ELSE} DesignWindows, {$ENDIF} SysUtils, Graphics, ActnList,
Controls, Forms, TntDesignEditors_Design, TntActnList, TntMenus, OPopupMenu;
procedure Register;
begin
//RegisterComponentEditor(TMainMenu, TOMenuEditor);
RegisterComponentEditor(TOPopupMenu, TOMenuEditor);
end;
function GetMenuBuilder: TForm{TNT-ALLOW TForm};
{$IFDEF MNUBUILD_AVAILABLE}
begin
Result := MenuEditor;
{$ELSE}
var
Comp: TComponent;
begin
Result := nil;
if Application <> nil then
begin
Comp := Application.FindComponent('MenuBuilder');
if Comp is TForm{TNT-ALLOW TForm} then
Result := TForm{TNT-ALLOW TForm}(Comp);
end;
{$ENDIF}
end;
{$IFDEF DELPHI_9} // verified against Delphi 9
type
THackMenuBuilder = class(TDesignWindow)
protected
Fields: array[1..26] of TObject;
FWorkMenu: TMenuItem{TNT-ALLOW TMenuItem};
end;
{$ENDIF}
{$IFDEF COMPILER_10_UP}
{$IFDEF DELPHI_10} // NOT verified against Delphi 10
type
THackMenuBuilder = class(TDesignWindow)
protected
Fields: array[1..26] of TObject;
FWorkMenu: TMenuItem{TNT-ALLOW TMenuItem};
end;
{$ENDIF}
{$ENDIF}
function GetMenuBuilder_WorkMenu(MenuBuilder: TForm{TNT-ALLOW TForm}): TMenuItem{TNT-ALLOW TMenuItem};
begin
if MenuBuilder = nil then
Result := nil
else begin
{$IFDEF MNUBUILD_AVAILABLE}
Result := MenuEditor.WorkMenu;
{$ELSE}
Result := THackMenuBuilder(MenuBuilder).FWorkMenu;
Assert((Result = nil) or (Result is TMenuItem{TNT-ALLOW TMenuItem}),
'TNT Internal Error: THackMenuBuilder has incorrect internal layout.');
{$ENDIF}
end;
end;
{$IFDEF DELPHI_9} // verified against Delphi 9
type
THackMenuItemWin = class(TCustomControl)
protected
FxxxxCaptionExtent: Integer;
FMenuItem: TMenuItem{TNT-ALLOW TMenuItem};
end;
{$ENDIF}
{$IFDEF DELPHI_10} // beta: NOT verified against Delphi 10
type
THackMenuItemWin = class(TCustomControl)
protected
FxxxxCaptionExtent: Integer;
FMenuItem: TMenuItem{TNT-ALLOW TMenuItem};
end;
{$ENDIF}
function GetMenuItem(Control: TWinControl; DoVerify: Boolean = True): TMenuItem{TNT-ALLOW TMenuItem};
begin
{$IFDEF MNUBUILD_AVAILABLE}
if Control is TMenuItemWin then
Result := TMenuItemWin(Control).MenuItem
{$ELSE}
if Control.ClassName = 'TMenuItemWin' then begin
Result := THackMenuItemWin(Control).FMenuItem;
Assert((Result = nil) or (Result is TMenuItem{TNT-ALLOW TMenuItem}), 'TNT Internal Error: Unexpected TMenuItem field layout.');
end
{$ENDIF}
else if DoVerify then
raise Exception.Create('TNT Internal Error: Control is not a TMenuItemWin.')
else
Result := nil;
end;
procedure SetMenuItem(Control: TWinControl; Item: TMenuItem{TNT-ALLOW TMenuItem});
begin
{$IFDEF MNUBUILD_AVAILABLE}
if Control is TMenuItemWin then
TMenuItemWin(Control).MenuItem := Item
{$ELSE}
if Control.ClassName = 'TMenuItemWin' then begin
THackMenuItemWin(Control).FMenuItem := Item;
Item.FreeNotification(Control);
end
{$ENDIF}
else
raise Exception.Create('TNT Internal Error: Control is not a TMenuItemWin.');
end;
procedure ReplaceMenuItem(Control: TWinControl; ANewItem: TMenuItem{TNT-ALLOW TMenuItem});
var
OldItem: TMenuItem{TNT-ALLOW TMenuItem};
OldName: string{TNT-ALLOW string};
begin
OldItem := GetMenuItem(Control, True);
Assert(OldItem <> nil);
OldName := OldItem.Name;
FreeAndNil(OldItem);
ANewItem.Name := OldName; { assume old name }
SetMenuItem(Control, ANewItem);
end;
{ TTntMenuBuilderChecker }
type
TMenuBuilderChecker = class(TComponent)
private
FMenuBuilder: TForm{TNT-ALLOW TForm};
FCheckMenuAction: TTntAction;
FLastCaption: string{TNT-ALLOW string};
FLastActiveControl: TControl;
FLastMenuItem: TMenuItem{TNT-ALLOW TMenuItem};
procedure CheckMenuItems(Sender: TObject);
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
end;
var MenuBuilderChecker: TMenuBuilderChecker = nil;
constructor TMenuBuilderChecker.Create(AOwner: TComponent);
begin
inherited;
MenuBuilderChecker := Self;
FCheckMenuAction := TTntAction.Create(Self);
FCheckMenuAction.OnUpdate := CheckMenuItems;
FCheckMenuAction.OnExecute := CheckMenuItems;
FMenuBuilder := AOwner as TForm{TNT-ALLOW TForm};
FMenuBuilder.Action := FCheckMenuAction;
end;
destructor TMenuBuilderChecker.Destroy;
begin
FMenuBuilder := nil;
MenuBuilderChecker := nil;
inherited;
end;
type TAccessOMenuItem = class(TOMenuItem);
function CreateOMenuItem(OldItem: TMenuItem{TNT-ALLOW TMenuItem}): TOMenuItem;
var
OldName: AnsiString;
OldParent: TMenuItem{TNT-ALLOW TMenuItem};
OldIndex: Integer;
OldItemsList: TList;
j: integer;
begin
// item should be converted.
OldItemsList := TList.Create;
try
// clone properties
Result := TOMenuItem.Create(OldItem.Owner);
TAccessOMenuItem(Result).FComponentStyle := OldItem.ComponentStyle; {csTransient hides item from object inspector}
Result.Action := OldItem.Action;
Result.AutoCheck := OldItem.AutoCheck;
Result.AutoHotkeys := OldItem.AutoHotkeys;
Result.AutoLineReduction := OldItem.AutoLineReduction;
Result.Bitmap := OldItem.Bitmap;
Result.Break := OldItem.Break;
Result.Caption := OldItem.Caption;
Result.Checked := OldItem.Checked;
Result.Default := OldItem.Default;
Result.Enabled := OldItem.Enabled;
Result.GroupIndex := OldItem.GroupIndex;
Result.HelpContext := OldItem.HelpContext;
Result.Hint := OldItem.Hint;
Result.ImageIndex := OldItem.ImageIndex;
Result.MenuIndex := OldItem.MenuIndex;
Result.RadioItem := OldItem.RadioItem;
Result.ShortCut := OldItem.ShortCut;
Result.SubMenuImages := OldItem.SubMenuImages;
Result.Visible := OldItem.Visible;
Result.Tag := OldItem.Tag;
// clone events
Result.OnAdvancedDrawItem := OldItem.OnAdvancedDrawItem;
Result.OnClick := OldItem.OnClick;
Result.OnDrawItem := OldItem.OnDrawItem;
Result.OnMeasureItem := OldItem.OnMeasureItem;
// remember name, parent, index, children
OldName := OldItem.Name;
OldParent := OldItem.Parent;
OldIndex := OldItem.MenuIndex;
for j := OldItem.Count - 1 downto 0 do begin
OldItemsList.Insert(0, OldItem.Items[j]);
OldItem.Remove(OldItem.Items[j]);
end;
// clone final parts of old item
for j := 0 to OldItemsList.Count - 1 do
Result.Add(TMenuItem{TNT-ALLOW TMenuItem}(OldItemsList[j])); { add children }
if OldParent <> nil then
OldParent.Insert(OldIndex, Result); { insert into parent }
finally
OldItemsList.Free;
end;
end;
procedure CheckMenuItemWin(MenuItemWin: TWinControl; PartOfATntMenu: Boolean);
var
OldItem: TMenuItem{TNT-ALLOW TMenuItem};
begin
OldItem := GetMenuItem(MenuItemWin);
if OldItem = nil then
exit;
if (OldItem.ClassType = TMenuItem{TNT-ALLOW TMenuItem})
and (PartOfATntMenu or (OldItem.Parent is TOMenuItem)) then
begin
if MenuItemWin.Focused then
MenuItemWin.Parent.SetFocus; {Lose focus and regain later to ensure object inspector gets updated.}
ReplaceMenuItem(MenuItemWin, CreateOMenuItem(OldItem));
end else if (OldItem.ClassType = TOMenuItem)
and (OldItem.Parent = nil) and (OldItem.Caption = '') and (OldItem.Name = '')
and not (PartOfATntMenu or (OldItem.Parent is TOMenuItem)) then begin
if MenuItemWin.Focused then
MenuItemWin.Parent.SetFocus; {Lose focus and regain later to ensure object inspector gets updated.}
ReplaceMenuItem(MenuItemWin, TMenuItem{TNT-ALLOW TMenuItem}.Create(OldItem.Owner));
end;
end;
procedure TMenuBuilderChecker.CheckMenuItems(Sender: TObject);
var
a, i: integer;
MenuWin: TWinControl;
MenuItemWin: TWinControl;
SaveFocus: HWND;
PartOfATntMenu: Boolean;
WorkMenu: TMenuItem{TNT-ALLOW TMenuItem};
begin
if (FMenuBuilder <> nil)
and (FMenuBuilder.Action = FCheckMenuAction) then begin
if (FLastCaption <> FMenuBuilder.Caption)
or (FLastActiveControl <> FMenuBuilder.ActiveControl)
or (FLastMenuItem <> GetMenuItem(FMenuBuilder.ActiveControl, False))
then begin
try
try
with FMenuBuilder do begin
WorkMenu := GetMenuBuilder_WorkMenu(FMenuBuilder);
PartOfATntMenu := (WorkMenu <> nil)
and ((WorkMenu.Owner is TTntMainMenu) or (WorkMenu.Owner is TTntPopupMenu));
SaveFocus := Windows.GetFocus;
for a := ComponentCount - 1 downto 0 do begin
{$IFDEF MNUBUILD_AVAILABLE}
if Components[a] is TMenuWin then begin
{$ELSE}
if Components[a].ClassName = 'TMenuWin' then begin
{$ENDIF}
MenuWin := Components[a] as TWinControl;
with MenuWin do begin
for i := ComponentCount - 1 downto 0 do begin
{$IFDEF MNUBUILD_AVAILABLE}
if Components[i] is TMenuItemWin then begin
{$ELSE}
if Components[i].ClassName = 'TMenuItemWin' then begin
{$ENDIF}
MenuItemWin := Components[i] as TWinControl;
CheckMenuItemWin(MenuItemWin, PartOfATntMenu);
end;
end;
end;
end;
end;
if SaveFocus <> Windows.GetFocus then
Windows.SetFocus(SaveFocus);
end;
except
on E: Exception do begin
FMenuBuilder.Action := nil;
end;
end;
finally
FLastCaption := FMenuBuilder.Caption;
FLastActiveControl := FMenuBuilder.ActiveControl;
FLastMenuItem := GetMenuItem(FMenuBuilder.ActiveControl, False);
end;
end;
end;
end;
{ TOMenuEditor }
function TOMenuEditor.GetVerbCount: Integer;
begin
Result := 1;
end;
{$IFNDEF MNUBUILD_AVAILABLE}
resourcestring
SMenuDesigner = 'Menu Designer...';
{$ENDIF}
function TOMenuEditor.GetVerb(Index: Integer): string{TNT-ALLOW string};
begin
Result := SMenuDesigner;
end;
procedure TOMenuEditor.ExecuteVerb(Index: Integer);
var
MenuBuilder: TForm{TNT-ALLOW TForm};
begin
EditPropertyWithDialog(Component, 'Items', Designer);
MenuBuilder := GetMenuBuilder;
if Assigned(MenuBuilder) then begin
if (MenuBuilderChecker = nil) or (MenuBuilderChecker.FMenuBuilder <> MenuBuilder) then begin
MenuBuilderChecker.Free;
MenuBuilderChecker := TMenuBuilderChecker.Create(MenuBuilder);
end;
EditPropertyWithDialog(Component, 'Items', Designer); // update menu builder caption
end;
end;
initialization
finalization
if Assigned(MenuBuilderChecker) then
FreeAndNil(MenuBuilderChecker); // design package might be recompiled
end.
Upvotes: 1
Views: 2216
Reputation: 1006
I figured it out. The problem was in THackMenuBuilder. This code works for both D2007 and DXE2.
Maybe somebody finds it useful if he writes custom menus.
OMenus_Editors.pas:
{*****************************************************************************}
{ }
{ Modified by oxo (http://www.kluug.at) }
{ }
{ Original Code (TntMenus_Editors.pas) }
{ }
{ Tnt Delphi Unicode Controls }
{ http://www.tntware.com/delphicontrols/unicode/ }
{ Version: 2.3.0 }
{ }
{ Copyright (c) 2002-2007, Troy Wolbrink (troy.wolbrink@tntware.com) }
{ }
{*****************************************************************************}
unit OMenus_Editors;
{*******************************************************}
{ Special Thanks to Francisco Leong for getting these }
{ menu designer enhancements to work w/o MnuBuild. }
{*******************************************************}
interface
{$IFDEF VER150}//Delphi 7
{$DEFINE MNUBUILD_AVAILABLE}
{$ENDIF}
{$IFDEF VER140}//Delphi 6
{$DEFINE MNUBUILD_AVAILABLE}
{$ENDIF}
uses
Windows, Classes, Menus, Messages,
{$IFDEF MNUBUILD_AVAILABLE} MnuBuild, {$ENDIF}
DesignEditors, DesignIntf;
type
TOMenuEditor = class(TComponentEditor)
public
procedure ExecuteVerb(Index: Integer); override;
function GetVerb(Index: Integer): string; override;
function GetVerbCount: Integer; override;
end;
procedure Register;
implementation
uses
{$IFDEF MNUBUILD_AVAILABLE} MnuConst, {$ELSE} DesignWindows, {$ENDIF} SysUtils, Graphics, ActnList,
Controls, Forms, OPopupMenu, ODesignEditors_Design, Dialogs;
procedure Register;
begin
RegisterComponentEditor(TOPopupMenu, TOMenuEditor);
end;
function GetMenuBuilder: TCustomForm;
{$IFDEF MNUBUILD_AVAILABLE}
begin
Result := MenuEditor;
{$ELSE}
var
Comp: TComponent;
begin
Result := nil;
if Application <> nil then
begin
Comp := Application.FindComponent('MenuBuilder');
if Comp is TCustomForm then begin
Result := TCustomForm(Comp);
end;
end;
{$ENDIF}
end;
type
THackMenuBuilder = class(TDesignWindow)
protected
Fields: array[0..49] of TObject;
end;
function GetMenuBuilder_WorkMenu(MenuBuilder: TCustomForm): TMenuItem;
var I: Integer;
begin
if MenuBuilder = nil then
Result := nil
else begin
{$IFDEF MNUBUILD_AVAILABLE}
Result := MenuEditor.WorkMenu;
{$ELSE}
Result := nil;
for I := 25 to 35 do begin
try
if THackMenuBuilder(MenuBuilder).Fields[I] is TMenuItem then
Result := TMenuItem(THackMenuBuilder(MenuBuilder).Fields[I]);
except
end;
end;
Assert((Result = nil) or (Result is TMenuItem),
'OMenus Internal Error: THackMenuBuilder has incorrect internal layout.');
{$ENDIF}
end;
end;
type
THackMenuItemWin = class(TCustomControl)
protected
FxxxxCaptionExtent: Integer;
FMenuItem: TMenuItem;
end;
function GetMenuItem(Control: TWinControl; DoVerify: Boolean = True): TMenuItem;
begin
{$IFDEF MNUBUILD_AVAILABLE}
if Control is TMenuItemWin then
Result := TMenuItemWin(Control).MenuItem
{$ELSE}
if Control.ClassName = 'TMenuItemWin' then begin
Result := THackMenuItemWin(Control).FMenuItem;
Assert((Result = nil) or (Result is TMenuItem), 'OMenus Internal Error: Unexpected TMenuItem field layout.');
end
{$ENDIF}
else if DoVerify then
raise Exception.Create('OMenus Internal Error: Control is not a TMenuItemWin.')
else
Result := nil;
end;
procedure SetMenuItem(Control: TWinControl; Item: TMenuItem);
begin
{$IFDEF MNUBUILD_AVAILABLE}
if Control is TMenuItemWin then
TMenuItemWin(Control).MenuItem := Item
{$ELSE}
if Control.ClassName = 'TMenuItemWin' then begin
THackMenuItemWin(Control).FMenuItem := Item;
Item.FreeNotification(Control);
end
{$ENDIF}
else
raise Exception.Create('OMenus Internal Error: Control is not a TMenuItemWin.');
end;
procedure ReplaceMenuItem(Control: TWinControl; ANewItem: TMenuItem);
var
OldItem: TMenuItem;
OldName: string;
begin
OldItem := GetMenuItem(Control, True);
Assert(OldItem <> nil);
OldName := OldItem.Name;
FreeAndNil(OldItem);
ANewItem.Name := OldName; { assume old name }
SetMenuItem(Control, ANewItem);
end;
{ TMenuBuilderChecker }
type
TMenuBuilderChecker = class(TComponent)
private
FMenuBuilder: TCustomForm;
FCheckMenuAction: TAction;
FLastCaption: string;
FLastActiveControl: TControl;
FLastMenuItem: TMenuItem;
procedure CheckMenuItems(Sender: TObject);
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
end;
var MenuBuilderChecker: TMenuBuilderChecker = nil;
constructor TMenuBuilderChecker.Create(AOwner: TComponent);
begin
inherited;
MenuBuilderChecker := Self;
FCheckMenuAction := TAction.Create(Self);
FCheckMenuAction.OnUpdate := CheckMenuItems;
FCheckMenuAction.OnExecute := CheckMenuItems;
FMenuBuilder := AOwner as TCustomForm;
FMenuBuilder.Action := FCheckMenuAction;
end;
destructor TMenuBuilderChecker.Destroy;
begin
FMenuBuilder := nil;
MenuBuilderChecker := nil;
inherited;
end;
type TAccessOMenuItem = class(TOMenuItem);
function CreateOMenuItem(OldItem: TMenuItem): TOMenuItem;
var
OldName: AnsiString;
OldParent: TMenuItem;
OldIndex: Integer;
OldItemsList: TList;
j: integer;
begin
// item should be converted.
OldItemsList := TList.Create;
try
// clone properties
Result := TOMenuItem.Create(OldItem.Owner);
TAccessOMenuItem(Result).FComponentStyle := OldItem.ComponentStyle; {csTransient hides item from object inspector}
Result.Action := OldItem.Action;
Result.AutoCheck := OldItem.AutoCheck;
Result.AutoHotkeys := OldItem.AutoHotkeys;
Result.AutoLineReduction := OldItem.AutoLineReduction;
Result.Bitmap := OldItem.Bitmap;
Result.Break := OldItem.Break;
Result.Caption := OldItem.Caption;
Result.Checked := OldItem.Checked;
Result.Default := OldItem.Default;
Result.Enabled := OldItem.Enabled;
Result.GroupIndex := OldItem.GroupIndex;
Result.HelpContext := OldItem.HelpContext;
Result.Hint := OldItem.Hint;
Result.ImageIndex := OldItem.ImageIndex;
Result.MenuIndex := OldItem.MenuIndex;
Result.RadioItem := OldItem.RadioItem;
Result.ShortCut := OldItem.ShortCut;
Result.SubMenuImages := OldItem.SubMenuImages;
Result.Visible := OldItem.Visible;
Result.Tag := OldItem.Tag;
// clone events
Result.OnAdvancedDrawItem := OldItem.OnAdvancedDrawItem;
Result.OnClick := OldItem.OnClick;
Result.OnDrawItem := OldItem.OnDrawItem;
Result.OnMeasureItem := OldItem.OnMeasureItem;
// remember name, parent, index, children
OldName := OldItem.Name;
OldParent := OldItem.Parent;
OldIndex := OldItem.MenuIndex;
for j := OldItem.Count - 1 downto 0 do begin
OldItemsList.Insert(0, OldItem.Items[j]);
OldItem.Remove(OldItem.Items[j]);
end;
// clone final parts of old item
for j := 0 to OldItemsList.Count - 1 do
Result.Add(TMenuItem(OldItemsList[j])); { add children }
if OldParent <> nil then
OldParent.Insert(OldIndex, Result); { insert into parent }
finally
OldItemsList.Free;
end;
end;
procedure CheckMenuItemWin(MenuItemWin: TWinControl; PartOfAMenu: Boolean);
var
OldItem: TMenuItem;
begin
OldItem := GetMenuItem(MenuItemWin);
if OldItem = nil then
exit;
if (OldItem.ClassType = TMenuItem)
and (PartOfAMenu or (OldItem.Parent is TOMenuItem)) then
begin
if MenuItemWin.Focused then
MenuItemWin.Parent.SetFocus; {Lose focus and regain later to ensure object inspector gets updated.}
ReplaceMenuItem(MenuItemWin, CreateOMenuItem(OldItem));
end else if (OldItem.ClassType = TOMenuItem)
and (OldItem.Parent = nil) and (OldItem.Caption = '') and (OldItem.Name = '')
and not (PartOfAMenu or (OldItem.Parent is TOMenuItem)) then begin
if MenuItemWin.Focused then
MenuItemWin.Parent.SetFocus; {Lose focus and regain later to ensure object inspector gets updated.}
ReplaceMenuItem(MenuItemWin, TMenuItem.Create(OldItem.Owner));
end;
end;
procedure TMenuBuilderChecker.CheckMenuItems(Sender: TObject);
var
a, i: integer;
MenuWin: TWinControl;
MenuItemWin: TWinControl;
SaveFocus: HWND;
PartOfAMenu: Boolean;
WorkMenu: TMenuItem;
begin
if (FMenuBuilder <> nil)
and (FMenuBuilder.Action = FCheckMenuAction) then begin
if (FLastCaption <> FMenuBuilder.Caption)
or (FLastActiveControl <> FMenuBuilder.ActiveControl)
or (FLastMenuItem <> GetMenuItem(FMenuBuilder.ActiveControl, False))
then begin
try
try
with FMenuBuilder do begin
WorkMenu := GetMenuBuilder_WorkMenu(FMenuBuilder);
PartOfAMenu := (WorkMenu <> nil)
and ((WorkMenu.Owner is TMainMenu) or (WorkMenu.Owner is TPopupMenu));
//ShowMessage('CheckMenuItems: ' + BoolToStr((WorkMenu <> nil), True));
SaveFocus := Windows.GetFocus;
for a := ComponentCount - 1 downto 0 do begin
{$IFDEF MNUBUILD_AVAILABLE}
if Components[a] is TMenuWin then begin
{$ELSE}
if Components[a].ClassName = 'TMenuWin' then begin
{$ENDIF}
MenuWin := Components[a] as TWinControl;
with MenuWin do begin
for i := ComponentCount - 1 downto 0 do begin
{$IFDEF MNUBUILD_AVAILABLE}
if Components[i] is TMenuItemWin then begin
{$ELSE}
if Components[i].ClassName = 'TMenuItemWin' then begin
{$ENDIF}
MenuItemWin := Components[i] as TWinControl;
CheckMenuItemWin(MenuItemWin, PartOfAMenu);
end;
end;
end;
end;
end;
if SaveFocus <> Windows.GetFocus then
Windows.SetFocus(SaveFocus);
end;
except
on E: Exception do begin
FMenuBuilder.Action := nil;
end;
end;
finally
FLastCaption := FMenuBuilder.Caption;
FLastActiveControl := FMenuBuilder.ActiveControl;
FLastMenuItem := GetMenuItem(FMenuBuilder.ActiveControl, False);
end;
end;
end;
end;
{ TOMenuEditor }
function TOMenuEditor.GetVerbCount: Integer;
begin
Result := 1;
end;
{$IFNDEF MNUBUILD_AVAILABLE}
resourcestring
SMenuDesigner = 'Menu Designer...';
{$ENDIF}
function TOMenuEditor.GetVerb(Index: Integer): string;
begin
Result := SMenuDesigner;
end;
procedure TOMenuEditor.ExecuteVerb(Index: Integer);
var
MenuBuilder: TCustomForm;
begin
EditPropertyWithDialog(Component, 'Items', Designer);
MenuBuilder := GetMenuBuilder;
if Assigned(MenuBuilder) then begin
if (MenuBuilderChecker = nil) or (MenuBuilderChecker.FMenuBuilder <> MenuBuilder) then begin
MenuBuilderChecker.Free;
MenuBuilderChecker := TMenuBuilderChecker.Create(MenuBuilder);
end;
EditPropertyWithDialog(Component, 'Items', Designer); // update menu builder caption
end;
end;
initialization
finalization
if Assigned(MenuBuilderChecker) then
FreeAndNil(MenuBuilderChecker); // design package might be recompiled
end.
ODesignEditors_Design.pas:
{*****************************************************************************}
{ }
{ Modified by oxo (http://www.kluug.at) }
{ }
{ Original Code (ODesignEditors_Design.pas) }
{ }
{ Tnt Delphi Unicode Controls }
{ http://www.tntware.com/delphicontrols/unicode/ }
{ Version: 2.3.0 }
{ }
{ Copyright (c) 2002-2007, Troy Wolbrink (troy.wolbrink@tntware.com) }
{ }
{*****************************************************************************}
unit ODesignEditors_Design;
interface
uses
Classes, Forms, TypInfo, DesignIntf, DesignEditors;
procedure EditPropertyWithDialog(Component: TPersistent; const PropName: String; const Designer: IDesigner);
implementation
uses
SysUtils;
{ TPropertyEditorWithDialog }
type
TPropertyEditorWithDialog = class
private
FPropName: String;
procedure CheckEditProperty(const Prop: IProperty);
procedure EditProperty(Component: TPersistent; const PropName: String; const Designer: IDesigner);
end;
procedure TPropertyEditorWithDialog.CheckEditProperty(const Prop: IProperty);
begin
if Prop.GetName = FPropName then
Prop.Edit;
end;
procedure TPropertyEditorWithDialog.EditProperty(Component: TPersistent; const PropName: String; const Designer: IDesigner);
var
Components: IDesignerSelections;
begin
FPropName := PropName;
Components := TDesignerSelections.Create;
Components.Add(Component);
GetComponentProperties(Components, [tkClass], Designer, CheckEditProperty);
end;
procedure EditPropertyWithDialog(Component: TPersistent; const PropName: String; const Designer: IDesigner);
begin
with TPropertyEditorWithDialog.Create do
try
EditProperty(Component, PropName, Designer);
finally
Free;
end;
end;
end.
Upvotes: 1