Custom Menu Items in Delphi XE2 (Design Time)

Question

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

enter image description here

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 ([email protected])       }
{                                                                             }
{*****************************************************************************}

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.

oxo oxo · Accepted Answer · 2012-03-20T18:49:18

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 ([email protected])       }
{                                                                             }
{*****************************************************************************}

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 ([email protected])       }
{                                                                             }
{*****************************************************************************}

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.

Custom Menu Items in Delphi XE2 (Design Time)

1 Answers