{*******************************************************}
{                                                       }
{       Delphi Visual Component Library                 }
{                                                       }
{       Copyright (c) 1995 Borland International        }
{                                                       }
{*******************************************************}

unit Menus;

{$S-,W-,R-}
{$C PRELOAD}

interface

uses WinTypes, SysUtils, Classes, Messages;

const
  scShift = $2000;
  scCtrl = $4000;
  scAlt = $8000;
  scNone = 0;

type
  EMenuError = class(Exception);
  TMenu = class;
  TMenuBreak = (mbNone, mbBreak, mbBarBreak);
  TShortCut = Low(Word)..High(Word);
  TMenuChangeEvent = procedure (Sender: TObject; Rebuild: Boolean) of object;
  TMenuItem = class(TComponent)
  private
    FBreak: TMenuBreak;
    FCaption: PString;
    FChecked: Boolean;
    FEnabled: Boolean;
    FHandle: HMENU;
    FHelpContext: THelpContext;
    FHint: PString;
    FItems: TList;
    FShortCut: TShortCut;
    FVisible: Boolean;
    FGroupIndex: Byte;
    FOnChange: TMenuChangeEvent;
    FOnClick: TNotifyEvent;
    FCommand: Word;
    FParent: TMenuItem;
    FMerged: TMenuItem;
    procedure AppendTo(Menu: HMENU);
    procedure ClearHandles;
    procedure ReadShortCutText(Reader: TReader);
    procedure MergeWith(Menu: TMenuItem);
    procedure RebuildHandle;
    procedure PopulateMenu;
    procedure SubItemChanged(Sender: TObject; Rebuild: Boolean);
    procedure WriteShortCutText(Writer: TWriter);
    procedure VerifyGroupIndex(Position: Integer; Value: Byte);
  protected
    procedure DefineProperties(Filer: TFiler); override;
    function GetCaption: string;
    function GetHandle: HMENU;
    function GetHint: string;
    function GetCount: Integer;
    function GetItem(Index: Integer): TMenuItem;
    procedure MenuChanged(Rebuild: Boolean); dynamic;
    function HasParent: Boolean; override;
    procedure ReadState(Reader: TReader); override;
    procedure SetBreak(Value: TMenuBreak);
    procedure SetCaption(const Value: string);
    procedure SetChecked(Value: Boolean);
    procedure SetEnabled(Value: Boolean);
    procedure SetGroupIndex(Value: Byte);
    procedure SetHint(const Value: string);
    procedure SetShortCut(Value: TShortCut);
    procedure SetVisible(Value: Boolean);
    procedure WriteComponents(Writer: TWriter); override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Insert(Index: Integer; Item: TMenuItem);
    procedure Delete(Index: Integer);
    procedure Click; virtual;
    function IndexOf(Item: TMenuItem): Integer;
    procedure Add(Item: TMenuItem);
    procedure Remove(Item: TMenuItem);
    property Command: Word read FCommand;
    property Handle: HMENU read GetHandle;
    property Count: Integer read GetCount;
    property Items[Index: Integer]: TMenuItem read GetItem; default;
    property Parent: TMenuItem read FParent;
  published
    property Break: TMenuBreak read FBreak write SetBreak default mbNone;
    property Caption: string read GetCaption write SetCaption;
    property Checked: Boolean read FChecked write SetChecked default False;
    property Enabled: Boolean read FEnabled write SetEnabled default True;
    property GroupIndex: Byte read FGroupIndex write SetGroupIndex default 0;
    property HelpContext: THelpContext read FHelpContext write FHelpContext default 0;
    property Hint: string read GetHint write SetHint;
    property ShortCut: TShortCut read FShortCut write SetShortCut stored False;
    property Visible: Boolean read FVisible write SetVisible default True;
    property OnClick: TNotifyEvent read FOnClick write FOnClick;
  end;

  TFindItemKind = (fkCommand, fkHandle, fkShortCut);

  TMenu = class(TComponent)
  private
    FItems: TMenuItem;
    FWindowHandle: HWND;
    FMenuImage: PChar;
    procedure MenuChanged(Sender: TObject; Rebuild: Boolean); virtual;
    procedure SetWindowHandle(Value: HWND);
    function UpdateImage: Boolean;
  protected
    function GetHandle: HMENU; virtual;
    procedure WriteComponents(Writer: TWriter); override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    function DispatchCommand(ACommand: Word): Boolean;
    function DispatchPopup(AHandle: HMENU): Boolean;
    function FindItem(Value: Word; Kind: TFindItemKind): TMenuItem;
    function GetHelpContext(Value: Word; ByCommand: Boolean): THelpContext;
    function IsShortCut(var Message: TWMKey): Boolean;
    property Handle: HMENU read GetHandle;
    property WindowHandle: HWND read FWindowHandle write SetWindowHandle;
  published
    property Items: TMenuItem read FItems;
  end;

  TMainMenu = class(TMenu)
  private
    MergedMenu: TMenuItem;
    FOle2Menu: HMENU;
    FAutoMerge: Boolean;
    FReserved: Byte;
    procedure ItemChanged;
    procedure MenuChanged(Sender: TObject; Rebuild: Boolean); override;
    procedure SetAutoMerge(Value: Boolean);
  protected
    function GetHandle: HMENU; override;
  public
    procedure Merge(Menu: TMainMenu);
    procedure Unmerge(Menu: TMainMenu);
    procedure PopulateOle2Menu(SharedMenu: HMenu; Groups: array of Integer;
      var Widths: array of Longint);
    procedure GetOle2AcceleratorTable(var hAccel : THandle; var numAccels: Word;
      Groups: array of Integer);
    procedure SetOle2MenuHandle(Handle: HMENU);
  published
    property AutoMerge: Boolean read FAutoMerge write SetAutoMerge default False;
  end;

  TPopupAlignment = (paLeft, paRight, paCenter);

  TPopupMenu = class(TMenu)
  private
    FAlignment: TPopupAlignment;
    FAutoPopup: Boolean;
    FPopupComponent: TComponent;
    FOnPopup: TNotifyEvent;
    function GetHelpContext: THelpContext;
    procedure SetHelpContext(Value: THelpContext);
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Popup(X, Y: Integer); virtual;
    property PopupComponent: TComponent read FPopupComponent write FPopupComponent;
  published
    property Alignment: TPopupAlignment read FAlignment write FAlignment default paLeft;
    property AutoPopup: Boolean read FAutoPopup write FAutoPopup default True;
    property HelpContext: THelpContext read GetHelpContext write SetHelpContext default 0;
    property OnPopup: TNotifyEvent read FOnPopup write FOnPopup;
  end;

function ShortCut(Key: Word; Shift: TShiftState): TShortCut;
procedure ShortCutToKey(ShortCut: TShortCut; var Key: Word; var Shift: TShiftState);
function ShortCutToText(ShortCut: TShortCut): string;
function TextToShortCut(Text: string): TShortCut;

function NewMenu(Owner: TComponent; const AName: string; Items: array of TMenuItem): TMainMenu;
function NewPopupMenu(Owner: TComponent; const AName: string;
  Alignment: TPopupAlignment; AutoPopup: Boolean; Items: array of TMenuitem): TPopupMenu;
function NewSubMenu(const ACaption: string; hCtx: Word; const AName: string;
  Items: array of TMenuItem): TMenuItem;
function NewItem(const ACaption: string; AShortCut: TShortCut;
  AChecked, AEnabled: Boolean; AOnClick: TNotifyEvent; hCtx: Word;
  const AName: string): TMenuItem;
function NewLine: TMenuItem;

implementation

uses WinProcs, Controls, Forms, Consts;

procedure Error(const S: string);
begin
  raise EMenuError.Create(S);
end;

procedure IndexError;
begin
  Error(LoadStr(SMenuIndexError));
end;

{ TShortCut processing routines }

function ShortCut(Key: Word; Shift: TShiftState): TShortCut;
begin
  Result := 0;
  if WordRec(Key).Hi <> 0 then Exit;
  Result := Key;
  if ssShift in Shift then Inc(Result, scShift);
  if ssCtrl in Shift then Inc(Result, scCtrl);
  if ssAlt in Shift then Inc(Result, scAlt);
end;

procedure ShortCutToKey(ShortCut: TShortCut; var Key: Word; var Shift: TShiftState);
begin
  Key := Key and not (scShift + scCtrl + scAlt);
  Shift := [];
  if Key and scShift <> 0 then Include(Shift, ssShift);
  if Key and scCtrl <> 0 then Include(Shift, ssCtrl);
  if Key and scAlt <> 0 then Include(Shift, ssAlt);
end;

type
  TMenuKeyCap = (mkcBkSp, mkcTab, mkcEsc, mkcEnter, mkcSpace, mkcPgUp,
                 mkcPgDn, mkcEnd, mkcHome, mkcLeft, mkcUp, mkcRight,
                 mkcDown, mkcIns, mkcDel, mkcShift, mkcCtrl, mkcAlt);
const
  MenuKeyCapIDs: array[TMenuKeyCap] of Word =
    (SmkcBkSp, SmkcTab, SmkcEsc, SmkcEnter, SmkcSpace, SmkcPgUp,
     SmkcPgDn, SmkcEnd, SmkcHome, SmkcLeft, SmkcUp, SmkcRight,
     SmkcDown, SmkcIns, SmkcDel, SmkcShift, SmkcCtrl, SmkcAlt);
var
  MenuKeyCaps: array[TMenuKeyCap] of string[7];

procedure LoadStrings;
var
  i: TMenuKeyCap;
begin
  for i := mkcBkSp to mkcAlt do
    MenuKeyCaps[i] := LoadStr(MenuKeyCapIDs[i]);
end;

function ShortCutToText(ShortCut: TShortCut): string;
type
  TMenuKeyChar = 0..15;
  TRangeKind = (psNumeric, psAlpha, psSpecial1, psSpecial2);
  TKeyRange = record
    Start, Stop: Byte;
    case Kind: TRangeKind of
      psNumeric, psAlpha: (
        Prefix: PString);
      psSpecial1: (
        NamesIndex: TMenuKeyCap);
      psSpecial2: (
        CharsIndex: TMenuKeyChar);
  end;
const
  MulToDiv = 0;
  OemKey1 = 6;
  OemKey2 = 12;
  OemKey3 = 13;
  PrefixNil: string[1] = '';
  PrefixF: string[1] = 'F';
  MenuKeyChars: array[TMenuKeyChar] of string[1] =
    ('*', '+', '_', '-', '.', '/',
     ';', '=', ',', '-', '.', '/',
     '`',
     '[', '\', ']');
  Ranges: array[0..12] of TKeyRange = (
    (Start: $08; Stop: $09; Kind: psSpecial1; NamesIndex: mkcBkSp),
    (Start: $0D; Stop: $0D; Kind: psSpecial1; NamesIndex: mkcEnter),
    (Start: $1B; Stop: $1B; Kind: psSpecial1; NamesIndex: mkcEsc),
    (Start: $20; Stop: $28; Kind: psSpecial1; NamesIndex: mkcSpace),
    (Start: $2D; Stop: $2E; Kind: psSpecial1; NamesIndex: mkcIns),
    (Start: $30; Stop: $39; Kind: psNumeric; Prefix: @PrefixNil),
    (Start: $41; Stop: $5A; Kind: psAlpha;   Prefix: @PrefixNil),
    (Start: $60; Stop: $69; Kind: psNumeric; Prefix: @PrefixNil),
    (Start: $6A; Stop: $6F; Kind: psSpecial2; CharsIndex: MulToDiv),
    (Start: $6F; Stop: $87; Kind: psNumeric; Prefix: @PrefixF),
    (Start: $BA; Stop: $BF; Kind: psSpecial2; CharsIndex: OemKey1),
    (Start: $C0; Stop: $C0; Kind: psSpecial2; CharsIndex: OemKey2),
    (Start: $DB; Stop: $DD; Kind: psSpecial2; CharsIndex: OemKey3));
var
  I, C: Integer;
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];
  for I := Low(Ranges) to High(Ranges) do
    with Ranges[I] do
      if WordRec(ShortCut).Lo < Start then Exit
      else if WordRec(ShortCut).Lo <= Stop then
      begin
        case Kind of
          psSpecial1:
            Result := Result + MenuKeyCaps[TMenuKeyCap(Byte(NamesIndex) +
              WordRec(ShortCut).Lo - Start)];
          psSpecial2:
            Result := Result + MenuKeyChars[TMenuKeyChar(Byte(CharsIndex) +
              WordRec(ShortCut).Lo - Start)];
          psAlpha:
            Result := Result + Prefix^ + Char(WordRec(ShortCut).Lo -
              Start + Byte('A'));
          psNumeric:
            Result := Result + Prefix^ + IntToStr(WordRec(ShortCut).Lo -
              Start);
        end;
        Exit;
      end;
  Result := '';
end;

{ This function is *very* slow.  Use sparingly.  Return 0 if no VK code was found
  for the text }
function TextToShortCut(Text: string): TShortCut;
var
  Done: Boolean;

  { 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 CompareText(Copy(Text, 1, Length(Front)), 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 $87 do { Copy range from table in ShortCutToText }
    if CompareText(Text, ShortCutToText(Key)) = 0 then
    begin
      Result := Key or Shift;
      Exit;
    end;
end;

{ Menu command managment }

{ TBitPool }
const
  BitPoolSize = 4096;
  BitsPerInt = SizeOf(Integer) * 8;
type
  TBitEnum = 0..BitsPerInt - 1;
  TBitSet = set of TBitEnum;
  TBitPool = class
  private
    FBits: array [0..BitPoolSize div BitsPerInt - 1] of TBitSet;
    procedure SetBit(Index: Integer; Value: Boolean);
    function GetBit(Index: Integer): Boolean;
  public
    property Bits[Index: Integer]: Boolean read GetBit write SetBit; default;
    function OpenBit: Integer;
  end;

procedure TBitPool.SetBit(Index: Integer; Value: Boolean);
begin
  Dec(Index);
  if Value then
    Include(FBits[Index div BitsPerInt], Index mod BitsPerInt)
  else
    Exclude(FBits[Index div BitsPerInt], Index mod BitsPerInt);
end;

function TBitPool.GetBit(Index: Integer): Boolean;
begin
  Dec(Index);
  Result := Index mod BitsPerInt in FBits[Index div BitsPerInt];
end;

function TBitPool.OpenBit: Integer;
var
  I: Integer;
  B: TBitSet;
  J: TBitEnum;
begin
  for I := Low(FBits) to High(FBits) do
    if FBits[I] <> [0..BitsPerInt - 1] then
    begin
      B := FBits[I];
      for J := Low(J) to High(J) do
      begin
        if not (J in B) then
        begin
          Result := I * BitsPerInt + J + 1;
          Exit;
        end;
      end;
    end;
  Result := -1;
end;

var
  CommandPool: TBitPool;

function UniqueCommand: Word;
begin
  Result := CommandPool.OpenBit;
  CommandPool[Result] := True;
end;

{ Used to populate or merge menus }
procedure IterateMenus(Func: Pointer; Menu1, Menu2: TMenuItem);
var
  I, J: Integer;
  IIndex, JIndex: Byte;
  Menu1Size, Menu2Size: Integer;
  Done: Boolean;

  function Iterate(var I: Integer; MenuItem: TMenuItem; AFunc: Word): Boolean;
  var
    Item: TMenuItem;
  begin
    if MenuItem = nil then Exit;
    Result := False;
    while not Result and (I < MenuItem.Count) do
    begin
      Item := MenuItem[I];
      if Item.GroupIndex > IIndex then Break;
      asm
                PUSH    Item.Word[2]
                PUSH    Item.Word[0]
                MOV     BX,[BP+4]
                PUSH    WORD PTR SS:[BX]
                CALL    WORD PTR AFunc
                MOV     Result,AL
      end;
      Inc(I);
    end;
  end;

begin
  I := 0;
  J := 0;
  Menu1Size := 0;
  Menu2Size := 0;
  if Menu1 <> nil then Menu1Size := Menu1.Count;
  if Menu2 <> nil then Menu2Size := Menu2.Count;
  Done := False;
  while not Done and ((I < Menu1Size) or (J < Menu2Size)) do
  begin
    IIndex := High(Byte);
    JIndex := High(Byte);
    if (I < Menu1Size) then IIndex := Menu1[I].GroupIndex;
    if (J < Menu2Size) then JIndex := Menu2[J].GroupIndex;
    if IIndex <= JIndex then Done := Iterate(I, Menu1, PtrRec(Func).Ofs)
    else
    begin
      IIndex := JIndex;
      Done := Iterate(J, Menu2, PtrRec(Func).Ofs);
    end;
    while (I < Menu1Size) and (Menu1[I].GroupIndex <= IIndex) do Inc(I);
    while (J < Menu2Size) and (Menu2[J].GroupIndex <= IIndex) do Inc(J);
  end;
end;

{ TMenuItem }

constructor TMenuItem.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FCaption := NewStr('');
  FVisible := True;
  FEnabled := True;
  FHint := NullStr;
  FCommand := UniqueCommand;
end;

destructor TMenuItem.Destroy;
begin
  if FParent <> nil then
  begin
    FParent.Remove(Self);
    FParent := nil;
  end;
  if FHandle <> 0 then
  begin
    MergeWith(nil);
    DestroyMenu(FHandle);
    ClearHandles;
  end;
  while Count > 0 do Items[0].Free;
  FItems.Free;
  DisposeStr(FCaption);
  if FCommand <> 0 then CommandPool[FCommand] := False;
  inherited Destroy;
end;

procedure TMenuItem.ClearHandles;

  procedure Clear(Item: TMenuItem);
  var
    I: Integer;
  begin
    with Item do
    begin
      FHandle := 0;
      for I := 0 to GetCount - 1 do Clear(FItems[I]);
    end;
  end;

begin
  Clear(Self);
end;

procedure TMenuItem.AppendTo(Menu: HMENU);
const
  Breaks: array[TMenuBreak] of Longint = (0, MF_MENUBREAK, MF_MENUBARBREAK);
  Checks: array[Boolean] of LongInt = (MF_UNCHECKED, MF_CHECKED);
  Enables: array[Boolean] of LongInt = (MF_DISABLED or MF_GRAYED,
    MF_ENABLED);
  Separators: array[Boolean] of LongInt = (MF_STRING, MF_SEPARATOR);
var
  CCaption: array[0..255] of Char;
  NewFlags: Word;
begin
  if FVisible then
  begin
    StrPCopy(CCaption, FCaption^);
    NewFlags := Breaks[FBreak] or Checks[FChecked] or Enables[FEnabled] or
      Separators[FCaption^ = '-'] or MF_BYPOSITION;
    if GetCount > 0 then
      InsertMenu(Menu, Word(-1), MF_POPUP or NewFlags, GetHandle, CCaption)
    else
    begin
      if (FShortCut <> scNone) and ((Parent = nil) or (Parent.Parent <> nil) or
        not (Parent.Owner is TMainMenu)) then
        StrPCopy(StrECopy(StrEnd(CCaption), #9), ShortCutToText(FShortCut));
      InsertMenu(Menu, Word(-1), NewFlags, Command, CCaption);
    end;
  end;
end;

procedure TMenuItem.PopulateMenu;

  function AddIn(MenuItem: TMenuItem): Boolean;
  begin
    MenuItem.AppendTo(FHandle);
    Result := False;
  end;

begin
  IterateMenus(@AddIn, FMerged, Self);
end;

procedure TMenuItem.ReadShortCutText(Reader: TReader);
begin
  ShortCut := TextToShortCut(Reader.ReadString);
end;

procedure TMenuItem.MergeWith(Menu: TMenuItem);
begin
  if FMerged <> Menu then
  begin
    FMerged := Menu;
    RebuildHandle;
  end;
end;

procedure TMenuItem.RebuildHandle;
begin
  while GetMenuItemCount(Handle) > 0 do RemoveMenu(Handle, 0, MF_BYPOSITION);
  PopulateMenu;
  MenuChanged(False);
end;

procedure TMenuItem.VerifyGroupIndex(Position: Integer; Value: Byte);
var
  I: Integer;
begin
  for I := 0 to GetCount - 1 do
    if I < Position then
    begin
      if Items[I].GroupIndex > Value then Error(LoadStr(SGroupIndexTooLow))
    end
    else
      { Ripple change to menu items at Position and after }
      if Items[I].GroupIndex < Value then Items[I].FGroupIndex := Value;
end;

procedure TMenuItem.WriteShortCutText(Writer: TWriter);
begin
  Writer.WriteString(ShortCutToText(ShortCut));
end;

function TMenuItem.GetHandle: HMENU;
var
  I: Integer;
begin
  if FHandle = 0 then
  begin
    if Owner is TPopupMenu then
      FHandle := CreatePopupMenu
    else
      FHandle := CreateMenu;
    if FHandle = 0 then raise EMenuError.Create(LoadStr(SOutOfResources));
    PopulateMenu;
  end;
  Result := FHandle;
end;

function TMenuItem.GetHint;
begin
  Result := FHint^;
end;

procedure TMenuItem.DefineProperties(Filer: TFiler);
begin
  inherited DefineProperties(Filer);
  Filer.DefineProperty('ShortCutText', ReadShortCutText, WriteShortCutText,
    ShortCut <> 0);
end;

function TMenuItem.GetCaption: string;
begin
  Result := FCaption^;
end;

function TMenuItem.HasParent: Boolean;
begin
  Result := True;
end;

procedure TMenuItem.ReadState(Reader: TReader);
begin
  with Reader do
    if Parent is TMenu then TMenu(Parent).Items.Add(Self)
    else if Parent is TMenuItem then TMenuItem(Parent).Add(Self);
  inherited ReadState(Reader);
end;

procedure TMenuItem.SetBreak(Value: TMenuBreak);
begin
  if FBreak <> Value then
  begin
    FBreak := Value;
    MenuChanged(True);
  end;
end;

procedure TMenuItem.SetCaption(const Value: string);
begin
  if FCaption^ <> Value then
  begin
    AssignStr(FCaption, Value);
    MenuChanged(True);
  end;
end;

procedure TMenuItem.SetChecked(Value: Boolean);
begin
  if FChecked <> Value then
  begin
    FChecked := Value;
    MenuChanged(True);
  end;
end;

procedure TMenuItem.SetEnabled(Value: Boolean);
begin
  if FEnabled <> Value then
  begin
    FEnabled := Value;
    MenuChanged(True);
  end;
end;

procedure TMenuItem.SetHint(const Value: string);
begin
  AssignStr(FHint, Value);
end;

procedure TMenuItem.SetGroupIndex(Value: Byte);
begin
  if FGroupIndex <> Value then
  begin
    if Parent <> nil then Parent.VerifyGroupIndex(Parent.IndexOf(Self), Value);
    FGroupIndex := Value;
  end;
end;

function TMenuItem.GetCount: Integer;
begin
  if FItems = nil then Result := 0
  else Result := FItems.Count;
end;

function TMenuItem.GetItem(Index: Integer): TMenuItem;
begin
  if FItems = nil then IndexError;
  Result := FItems[Index];
end;

procedure TMenuItem.SetShortCut(Value: TShortCut);
begin
  FShortCut := Value;
  MenuChanged(True);
end;

procedure TMenuItem.SetVisible(Value: Boolean);
begin
  FVisible := Value;
  MenuChanged(True);
end;

procedure TMenuItem.WriteComponents(Writer: TWriter);
var
  I: Integer;
  MenuItem: TMenuItem;
begin
  for I := 0 to Count - 1 do
  begin
    MenuItem := Items[I];
    if MenuItem.Owner = Writer.Root then Writer.WriteComponent(MenuItem);
  end;
end;

procedure TMenuItem.Insert(Index: Integer; Item: TMenuItem);
begin
  if Item.FParent <> nil then
    raise EMenuError.Create(LoadStr(SMenuReinserted));
  if FItems = nil then FItems := TList.Create;
  if (Index - 1 >= 0) and (Index -1 < FItems.Count) then
    if Item.GroupIndex < TMenuItem(FItems[Index - 1]).GroupIndex then
      Item.GroupIndex := TMenuItem(FItems[Index - 1]).GroupIndex;
  VerifyGroupIndex(Index, Item.GroupIndex);
  FItems.Insert(Index, Item);
  Item.FParent := Self;
  Item.FOnChange := SubItemChanged;
  if FHandle <> 0 then RebuildHandle;
  MenuChanged(True);
end;

procedure TMenuItem.Delete(Index: Integer);
var
  Cur: TMenuItem;
begin
  if (Index < 0) or (FItems = nil) or (Index >= GetCount) then IndexError;
  Cur := FItems[Index];
  FItems.Delete(Index);
  Cur.FParent := nil;
  Cur.FOnChange := nil;
  if FHandle <> 0 then RebuildHandle;
  MenuChanged(True);
end;

procedure TMenuItem.Click;
begin
  if FEnabled and Assigned(FOnClick) then FOnClick(Self);
end;

function TMenuItem.IndexOf(Item: TMenuItem): Integer;
begin
  Result := -1;
  if FItems <> nil then Result := FItems.IndexOf(Item);
end;

procedure TMenuItem.Add(Item: TMenuItem);
begin
  Insert(GetCount, Item);
end;

procedure TMenuItem.Remove(Item: TMenuItem);
var
  I: Integer;
begin
  I := IndexOf(Item);
  if I = -1 then raise EMenuError.Create(LoadStr(SMenuNotFound));
  Delete(I);
end;

procedure TMenuItem.MenuChanged(Rebuild: Boolean);
begin
  if Assigned(FOnChange) then FOnChange(Self, Rebuild);
end;

procedure TMenuItem.SubItemChanged(Sender: TObject; Rebuild: Boolean);
begin
  if Rebuild and (FHandle <> 0) then RebuildHandle;
  if Parent <> nil then Parent.SubItemChanged(Self, False)
  else if Owner is TMainMenu then TMainMenu(Owner).ItemChanged;
end;

{ TMenu }

constructor TMenu.Create(AOwner: TComponent);
begin
  FItems := TMenuItem.Create(Self);
  FItems.FOnChange := MenuChanged;
  inherited Create(AOwner);
end;

destructor TMenu.Destroy;
begin
  FItems.Free;
  inherited Destroy;
end;

function TMenu.GetHandle: HMENU;
begin
  Result := FItems.GetHandle;
end;

procedure TMenu.WriteComponents(Writer: TWriter);
begin
  Items.WriteComponents(Writer);
end;

function TMenu.FindItem(Value: Word; Kind: TFindItemKind): TMenuItem;
var
  FoundItem: TMenuItem;

  function Find(Item: TMenuItem): Boolean;
  var
    I: Integer;
  begin
    Result := False;
    if ((Kind = fkCommand) and (Value = Item.Command)) or
      ((Kind = fkHandle) and (Value = Item.FHandle)) or
      ((Kind = fkShortCut) and (Value = Item.ShortCut)) then
    begin
      FoundItem := Item;
      Result := True;
      Exit;
    end
    else
      for I := 0 to Item.GetCount - 1 do
        if Find(Item[I]) then
        begin
          Result := True;
          Exit;
        end;
  end;

begin
  FoundItem := nil;
  IterateMenus(@Find, Items.FMerged, Items);
  Result := FoundItem;
end;

function TMenu.GetHelpContext(Value: Word; ByCommand: Boolean): THelpContext;
var
  Item: TMenuItem;
  Kind: TFindItemKind;
begin
  Result := 0;
  Kind := fkHandle;
  if ByCommand then Kind := fkCommand;
  Item := FindItem(Value, Kind);
  while (Item <> nil) and (Item.FHelpContext = 0) do
    Item := Item.FParent;
  if Item <> nil then Result := Item.FHelpContext;
end;

function TMenu.DispatchCommand(ACommand: Word): Boolean;
var
  Item: TMenuItem;
begin
  Result := False;
  Item := FindItem(ACommand, fkCommand);
  if Item <> nil then
  begin
    Item.Click;
    Result := True;
  end;
end;

function TMenu.DispatchPopup(AHandle: HMENU): Boolean;
var
  Item: TMenuItem;
begin
  Result := False;
  Item := FindItem(AHandle, fkHandle);
  if Item <> nil then
  begin
    Item.Click;
    Result := True;
  end;
end;

function TMenu.IsShortCut(var Message: TWMKey): Boolean;
const
  AltMask = $20000000;
var
  ShortCut: TShortCut;
  Item: TMenuItem;

  function IsEnabled(Item: TMenuItem): Boolean;
  begin
    Result := Item.Enabled and ((Item.Parent = nil) or IsEnabled(Item.Parent));
  end;

  function Click(Item: TMenuItem; ShortCut: TShortCut): Boolean;
  begin
    Result := False;
    if Item.Enabled then
      if (Item.Parent = nil) or Click(Item.Parent, Item.Parent.ShortCut) then
        if IsEnabled(Item) and (Item.ShortCut = ShortCut) then
        begin
          try
            Item.Click;
          except
            Application.HandleException(Self);
          end;
          Result := True;
        end;
  end;

begin
  Result := False;
  if FWindowHandle <> 0 then
  begin
    ShortCut := Byte(Message.CharCode);
    if GetKeyState(VK_SHIFT) < 0 then Inc(ShortCut, scShift);
    if GetKeyState(VK_CONTROL) < 0 then Inc(ShortCut, scCtrl);
    if Message.KeyData and AltMask <> 0 then Inc(ShortCut, scAlt);
    Item := FindItem(ShortCut, fkShortCut);
    if Item <> nil then
    begin
      Result := Click(Item, ShortCut);
      { Maybe the short-cut moved }
      if not Result and (Item.ShortCut <> ShortCut) then
      begin
        Item := FindItem(ShortCut, fkShortCut);
        if Item <> nil then Result := Click(Item, ShortCut);
      end;
    end;
  end;
end;

function TMenu.UpdateImage: Boolean;
var
  Image: array[0..511] of Char;

  procedure BuildImage(Menu: HMENU);
  var
    P, ImageEnd: PChar;
    I, C: Integer;
    State: Word;
  begin
    C := GetMenuItemCount(Menu);
    P := Image;
    ImageEnd := @Image[SizeOf(Image) - 5];
    I := 0;
    while (I < C) and (P < ImageEnd) do
    begin
      GetMenuString(Menu, I, P, ImageEnd - P, MF_BYPOSITION);
      P := StrEnd(P);
      State := GetMenuState(Menu, I, MF_BYPOSITION);
      if State and MF_DISABLED <> 0 then P := StrECopy(P, '$');
      if State and MF_MENUBREAK <> 0 then P := StrECopy(P, '@');
      if State and MF_GRAYED <> 0 then P := StrECopy(P, '#');
      P := StrECopy(P, ';');
      Inc(I);
    end;
  end;

begin
  Result := False;
  BuildImage(Handle);
  if (FMenuImage = nil) or (StrComp(FMenuImage, Image) <> 0) then
  begin
    Result := True;
    StrDispose(FMenuImage);
    FMenuImage := nil;
    FMenuImage := StrNew(Image);
  end;
end;

procedure TMenu.SetWindowHandle(Value: HWND);
begin
  FWindowHandle := Value;
  UpdateImage;
end;

procedure TMenu.MenuChanged(Sender: TObject; Rebuild: Boolean);
begin
end;

{ TMainMenu }

procedure TMainMenu.SetAutoMerge(Value: Boolean);
begin
  if FAutoMerge <> Value then
  begin
    FAutoMerge := Value;
    if FWindowHandle <> 0 then SendMessage(FWindowHandle, CM_MENUCHANGED, 0, 0);
  end;
end;

procedure TMainMenu.MenuChanged(Sender: TObject; Rebuild: Boolean);
begin
  if (FWindowHandle <> 0) and UpdateImage then DrawMenuBar(FWindowHandle);
end;

procedure TMainMenu.Merge(Menu: TMainMenu);
begin
  if Menu <> nil then FItems.MergeWith(Menu.FItems)
  else FItems.MergeWith(nil);
end;

procedure TMainMenu.Unmerge(Menu: TMainMenu);
begin
  if (Menu <> nil) and (FItems.FMerged = Menu.FItems) then
    FItems.MergeWith(nil);
end;

procedure TMainMenu.ItemChanged;
begin
  if WindowHandle <> 0 then SendMessage(WindowHandle, CM_MENUCHANGED, 0, 0);
end;

function TMainMenu.GetHandle: HMENU;
begin
  if FOle2Menu <> 0 then
    Result := FOle2Menu else
    Result := inherited GetHandle;
end;

procedure TMainMenu.GetOle2AcceleratorTable (var hAccel : THandle;
                      var numAccels : Word; Groups: array of Integer);
var
  NumGroups : Integer;
  J         : Integer;
  pAcc      : PAccel;

  function DoCountAccels(Item: TMenuItem): Boolean;
  var
    I: Integer;
  begin
    Result := False;
    if (Item.ShortCut <> 0) then
    begin
      NumAccels := NumAccels + 1;
    end
    else
    begin
      for I := 0 to Item.GetCount - 1 do
      begin
        Result := DoCountAccels (Item[I]);
      end;
    end;
  end;

  function CountAccelItems(Item: TMenuItem): Boolean;
  var
    I: Integer;
  begin
      {add this item if it matches one of the desired groups}
    Result := False;
    for I := 0 to NumGroups do
    begin
      if Item.GroupIndex = Groups[I] then
      begin
        DoCountAccels (Item);
        Exit;
      end;
    end;
  end;


  function DoAddAccels(Item: TMenuItem): Boolean;
  var
    I: Integer;
  begin
    Result := False;
    if (Item.ShortCut <> 0) then
    begin
      pAcc^.fVirt := $80 or FNOINVERT or FVIRTKEY;
      if (scCtrl and Item.ShortCut) <> 0 then
         pAcc^.fVirt := pAcc^.fVirt or FCONTROL;
      if (scAlt and Item.ShortCut) <> 0 then
         pAcc^.fVirt := pAcc^.fVirt or FALT;
      if (scShift and Item.ShortCut) <> 0 then
         pAcc^.fVirt := pAcc^.fVirt or FSHIFT;

      pAcc^.Cmd := Item.Command;
      pAcc^.Key := Item.ShortCut and $FF;
      Inc (pAcc);
      J := J + 1;
    end
    else
    begin
      for I := 0 to Item.GetCount - 1 do
      begin
        Result := DoAddAccels (Item[I]);
      end;
    end;
  end;

  function AddAccelItems(Item: TMenuItem): Boolean;
  var
    I: Integer;
  begin
      {add this item if it matches one of the desired groups}
    Result := False;
    for I := 0 to NumGroups do
    begin
      if Item.GroupIndex = Groups[I] then
      begin
        DoAddAccels (Item);
        Exit;
      end;
    end;
  end;


begin
  J := 0;
  NumGroups := High(Groups);
  IterateMenus(@CountAccelItems, Items.FMerged, Items);

  hAccel := THandle (0);
  if NumAccels > 0 then
  begin
    hAccel := GlobalAlloc (0, NumAccels * sizeof (TAccel));
    pAcc   := PAccel (GlobalLock (hAccel));
    IterateMenus(@AddAccelItems, Items.FMerged, Items);
    GlobalUnlock (hAccel);
  end;
end;


  { similar to regular menuitem.populateMenus except that it only
    adds the specified group to the menu handle  }
  { similar to regular menuitem.populateMenus except that it only
    adds the specified group to the menu handle  }
procedure TMainMenu.PopulateOle2Menu(SharedMenu: HMenu;
  Groups: array of Integer; var Widths: array of Longint);
var
  NumGroups: Integer;
  J: Integer;

  function AddOle2(Item: TMenuItem): Boolean;
  var
    I: Integer;
  begin
      {add this item if it matches one of the desired groups}
    for I := 0 to NumGroups do
    begin
      if Item.GroupIndex = Groups[I] then
      begin
        Widths[Item.GroupIndex] := Widths[Item.GroupIndex] + 1;
        Item.AppendTo(SharedMenu);
      end;
    end;
    Result := False;
  end;

begin
  NumGroups := High(Groups);
  for J := 0 to High(Widths) do
    Widths[J] := 0;
  IterateMenus(@AddOle2, Items.FMerged, Items);
end;

procedure TMainMenu.SetOle2MenuHandle(Handle: HMENU);
begin
  FOle2Menu := Handle;
  ItemChanged;
end;

{ TPopupMenu }

type
  TPopupList = class(TList)
  private
    procedure WndProc(var Message: TMessage);
  public
    Window: HWND;
    FMenuHelp: THelpContext;
    procedure Add(Popup: TPopupMenu);
    procedure Remove(Popup: TPopupMenu);
  end;

var
  PopupList: TPopupList;

procedure TPopupList.WndProc(var Message: TMessage);
var
  I: Integer;
  MenuItem: TMenuItem;
  FindKind: TFindItemKind;
begin
  try
    case Message.Msg of
      WM_COMMAND:
        for I := 0 to Count - 1 do
          if TPopupMenu(Items[I]).DispatchCommand(Message.wParam) then Exit;
      WM_MENUSELECT:
        with TWMMenuSelect(Message) do
        begin
          FindKind := fkCommand;
          if MenuFlag and MF_POPUP <> 0 then FindKind := fkHandle;
          for I := 0 to Count - 1 do
          begin
            MenuItem := TPopupMenu(Items[I]).FindItem(IDItem, FindKind);
            if MenuItem <> nil then
            begin
              FMenuHelp := MenuItem.HelpContext;
              Application.Hint := MenuItem.Hint;
              Exit;
            end;
          end;
          FMenuHelp := 0;
          Application.Hint := '';
        end;
      WM_ENTERIDLE:
        if (TWMEnterIdle(Message).Source = MSGF_MENU) and
          (GetKeyState(VK_F1) < 0) and (FMenuHelp <> 0) then
        begin
          Application.HelpContext(FMenuHelp);
          FMenuHelp := 0;
          Exit;
        end;
    end;
    with Message do Result := DefWindowProc(Window, Msg, wParam, lParam);
  except
    Application.HandleException(Self);
  end;
end;

procedure TPopupList.Add(Popup: TPopupMenu);
begin
  if Count = 0 then Window := AllocateHWnd(WndProc);
  inherited Add(Popup);
end;

procedure TPopupList.Remove(Popup: TPopupMenu);
begin
  inherited Remove(Popup);
  if Count = 0 then DeallocateHWnd(Window);
end;

constructor TPopupMenu.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FWindowHandle := Application.Handle;
  FAutoPopup := True;
  PopupList.Add(Self);
end;

destructor TPopupMenu.Destroy;
begin
  PopupList.Remove(Self);
  inherited Destroy;
end;

function TPopupMenu.GetHelpContext: THelpContext;
begin
  Result := FItems.HelpContext;
end;

procedure TPopupMenu.SetHelpContext(Value: THelpContext);
begin
  FItems.HelpContext := Value;
end;

procedure TPopupMenu.Popup(X, Y: Integer);
const
  Flags: array[TPopupAlignment] of Word = (TPM_LEFTALIGN, TPM_RIGHTALIGN,
    TPM_CENTERALIGN);
begin
  if Assigned(FOnPopup) then FOnPopup(Self);
  PopupList.FMenuHelp := HelpContext;
  TrackPopupMenu(FItems.Handle, Flags[FAlignment] or TPM_RIGHTBUTTON, X, Y,
    0 { reserved}, PopupList.Window, nil);
end;

{ Menu building functions }

procedure InitMenuItems(AMenu: TMenu; Items: array of TMenuItem);
var
  I: Integer;

  procedure SetOwner(Item: TMenuItem);
  var
    I: Integer;
  begin
    if Item.Owner = nil then AMenu.Owner.InsertComponent(Item);
    for I := 0 to Item.Count - 1 do
      SetOwner(Item[I]);
  end;

begin
  for I := Low(Items) to High(Items) do
  begin
    SetOwner(Items[I]);
    AMenu.FItems.Add(Items[I]);
  end;
end;

function NewMenu(Owner: TComponent; const AName: string; Items: array of TMenuItem): TMainMenu;
begin
  Result := TMainMenu.Create(Owner);
  Result.Name := AName;
  InitMenuItems(Result, Items);
end;

function NewPopupMenu(Owner: TComponent; const AName: string;
  Alignment: TPopupAlignment; AutoPopup: Boolean; Items: array of TMenuItem): TPopupMenu;
begin
  Result := TPopupMenu.Create(Owner);
  Result.Name := AName;
  Result.AutoPopup := AutoPopup;
  Result.Alignment := Alignment;
  InitMenuItems(Result, Items);
end;

function NewSubMenu(const ACaption: string; hCtx: Word; const AName: string;
  Items: array of TMenuItem): TMenuItem;
var
  I: Integer;
begin
  Result := TMenuItem.Create(nil);
  for I := Low(Items) to High(Items) do
    Result.Add(Items[I]);
  Result.Caption := ACaption;
  Result.HelpContext := hCtx;
  Result.Name := AName;
end;

function NewItem(const ACaption: string; AShortCut: TShortCut;
  AChecked, AEnabled: Boolean; AOnClick: TNotifyEvent; hCtx: Word;
  const AName: string): TMenuItem;
begin
  Result := TMenuItem.Create(nil);
  with Result do
  begin
    Caption := ACaption;
    ShortCut := AShortCut;
    OnClick := AOnClick;
    HelpContext := hCtx;
    Checked := AChecked;
    Enabled := AEnabled;
    Name := AName;
  end;
end;

function NewLine: TMenuItem;
begin
  Result := TMenuItem.Create(nil);
  Result.Caption := '-';
end;

begin
  RegisterClasses([TMenuItem]);
  LoadStrings;
  CommandPool := TBitPool.Create;
  PopupList := TPopupList.Create;
end.

