home *** CD-ROM | disk | FTP | other *** search
/ PC Pro 1999 February / DPPCPRO0299.ISO / February / Delphi / Install / DATA.Z / MENUS.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1996-06-09  |  37.2 KB  |  1,360 lines
  1.  
  2. {*******************************************************}
  3. {                                                       }
  4. {       Delphi Visual Component Library                 }
  5. {                                                       }
  6. {       Copyright (c) 1995,96 Borland International     }
  7. {                                                       }
  8. {*******************************************************}
  9.  
  10. unit Menus;
  11.  
  12. {$S-,W-,R-}
  13. {$C PRELOAD}
  14.  
  15. interface
  16.  
  17. uses Windows, SysUtils, Classes, Messages;
  18.  
  19. const
  20.   scShift = $2000;
  21.   scCtrl = $4000;
  22.   scAlt = $8000;
  23.   scNone = 0;
  24.  
  25. type
  26.   EMenuError = class(Exception);
  27.   TMenu = class;
  28.   TMenuBreak = (mbNone, mbBreak, mbBarBreak);
  29.   TShortCut = Low(Word)..High(Word);
  30.   TMenuChangeEvent = procedure (Sender: TObject; Rebuild: Boolean) of object;
  31. {$OldClassLayout On}
  32.   TMenuItem = class(TComponent)
  33.   private
  34.     FCaption: string;
  35.     FHandle: HMENU;
  36.     FChecked: Boolean;
  37.     FEnabled: Boolean;
  38.     FDefault: Boolean;
  39.     FRadioItem: Boolean;
  40.     FVisible: Boolean;
  41.     FGroupIndex: Byte;
  42.     FBreak: TMenuBreak;
  43.     FCommand: Word;
  44.     FHelpContext: THelpContext;
  45.     FHint: string;
  46.     FItems: TList;
  47.     FShortCut: TShortCut;
  48.     FParent: TMenuItem;
  49.     FMerged: TMenuItem;
  50.     FMenu: TMenu;
  51.     FOnChange: TMenuChangeEvent;
  52.     FOnClick: TNotifyEvent;
  53.     procedure AppendTo(Menu: HMENU);
  54.     procedure ClearHandles;
  55.     procedure ReadShortCutText(Reader: TReader);
  56.     procedure MergeWith(Menu: TMenuItem);
  57.     procedure RebuildHandle;
  58.     procedure PopulateMenu;
  59.     procedure SubItemChanged(Sender: TObject; Rebuild: Boolean);
  60.     procedure WriteShortCutText(Writer: TWriter);
  61.     procedure VerifyGroupIndex(Position: Integer; Value: Byte);
  62.   protected
  63.     procedure DefineProperties(Filer: TFiler); override;
  64.     function GetHandle: HMENU;
  65.     function GetCount: Integer;
  66.     procedure GetChildren(Proc: TGetChildProc); override;
  67.     function GetItem(Index: Integer): TMenuItem;
  68.     function GetMenuIndex: Integer;
  69.     function GetParentComponent: TComponent; override;
  70.     procedure MenuChanged(Rebuild: Boolean); virtual;
  71.     function HasParent: Boolean; override;
  72.     procedure SetBreak(Value: TMenuBreak);
  73.     procedure SetCaption(const Value: string);
  74.     procedure SetChecked(Value: Boolean);
  75.     procedure SetChildOrder(Child: TComponent; Order: Integer); override;
  76.     procedure SetDefault(Value: Boolean);
  77.     procedure SetEnabled(Value: Boolean);
  78.     procedure SetGroupIndex(Value: Byte);
  79.     procedure SetMenuIndex(Value: Integer);
  80.     procedure SetParentComponent(Value: TComponent); override;
  81.     procedure SetRadioItem(Value: Boolean);
  82.     procedure SetShortCut(Value: TShortCut);
  83.     procedure SetVisible(Value: Boolean);
  84.   public
  85.     constructor Create(AOwner: TComponent); override;
  86.     destructor Destroy; override;
  87.     procedure Insert(Index: Integer; Item: TMenuItem);
  88.     procedure Delete(Index: Integer);
  89.     procedure Click; virtual;
  90.     function IndexOf(Item: TMenuItem): Integer;
  91.     procedure Add(Item: TMenuItem);
  92.     procedure Remove(Item: TMenuItem);
  93.     property Command: Word read FCommand;
  94.     property Handle: HMENU read GetHandle;
  95.     property Count: Integer read GetCount;
  96.     property Items[Index: Integer]: TMenuItem read GetItem; default;
  97.     property MenuIndex: Integer read GetMenuIndex write SetMenuIndex;
  98.     property Parent: TMenuItem read FParent;
  99.   published
  100.     property Break: TMenuBreak read FBreak write SetBreak default mbNone;
  101.     property Caption: string read FCaption write SetCaption;
  102.     property Checked: Boolean read FChecked write SetChecked default False;
  103.     property Default: Boolean read FDefault write SetDefault default False;
  104.     property Enabled: Boolean read FEnabled write SetEnabled default True;
  105.     property GroupIndex: Byte read FGroupIndex write SetGroupIndex default 0;
  106.     property HelpContext: THelpContext read FHelpContext write FHelpContext default 0;
  107.     property Hint: string read FHint write FHint;
  108.     property RadioItem: Boolean read FRadioItem write SetRadioItem default False;
  109.     property ShortCut: TShortCut read FShortCut write SetShortCut;
  110.     property Visible: Boolean read FVisible write SetVisible default True;
  111.     property OnClick: TNotifyEvent read FOnClick write FOnClick;
  112.   end;
  113. {$OldClassLayout Off}
  114.  
  115.   TFindItemKind = (fkCommand, fkHandle, fkShortCut);
  116.  
  117.   TMenu = class(TComponent)
  118.   private
  119.     FItems: TMenuItem;
  120.     FWindowHandle: HWND;
  121.     FMenuImage: string;
  122.     procedure MenuChanged(Sender: TObject; Rebuild: Boolean); virtual;
  123.     procedure SetWindowHandle(Value: HWND);
  124.     function UpdateImage: Boolean;
  125.   protected
  126.     procedure GetChildren(Proc: TGetChildProc); override;
  127.     function GetHandle: HMENU; virtual;
  128.     procedure SetChildOrder(Child: TComponent; Order: Integer); override;
  129.   public
  130.     constructor Create(AOwner: TComponent); override;
  131.     destructor Destroy; override;
  132.     function DispatchCommand(ACommand: Word): Boolean;
  133.     function DispatchPopup(AHandle: HMENU): Boolean;
  134.     function FindItem(Value: Integer; Kind: TFindItemKind): TMenuItem;
  135.     function GetHelpContext(Value: Word; ByCommand: Boolean): THelpContext;
  136.     function IsShortCut(var Message: TWMKey): Boolean;
  137.     property Handle: HMENU read GetHandle;
  138.     property WindowHandle: HWND read FWindowHandle write SetWindowHandle;
  139.   published
  140.     property Items: TMenuItem read FItems;
  141.   end;
  142.  
  143.   TMainMenu = class(TMenu)
  144.   private
  145.     MergedMenu: TMenuItem;
  146.     FOle2Menu: HMENU;
  147.     FAutoMerge: Boolean;
  148.     FReserved: Byte;
  149.     procedure ItemChanged;
  150.     procedure MenuChanged(Sender: TObject; Rebuild: Boolean); override;
  151.     procedure SetAutoMerge(Value: Boolean);
  152.   protected
  153.     function GetHandle: HMENU; override;
  154.   public
  155.     procedure Merge(Menu: TMainMenu);
  156.     procedure Unmerge(Menu: TMainMenu);
  157.     procedure PopulateOle2Menu(SharedMenu: HMenu; Groups: array of Integer;
  158.       var Widths: array of Longint);
  159.     procedure GetOle2AcceleratorTable(var AccelTable: HAccel;
  160.       var AccelCount: Integer; Groups: array of Integer);
  161.     procedure SetOle2MenuHandle(Handle: HMENU);
  162.   published
  163.     property AutoMerge: Boolean read FAutoMerge write SetAutoMerge default False;
  164.   end;
  165.  
  166.   TPopupAlignment = (paLeft, paRight, paCenter);
  167.  
  168.   TPopupMenu = class(TMenu)
  169.   private
  170.     FAlignment: TPopupAlignment;
  171.     FAutoPopup: Boolean;
  172.     FPopupComponent: TComponent;
  173.     FOnPopup: TNotifyEvent;
  174.     procedure DoPopup(Item: TObject);
  175.     function GetHelpContext: THelpContext;
  176.     procedure SetHelpContext(Value: THelpContext);
  177.   public
  178.     constructor Create(AOwner: TComponent); override;
  179.     destructor Destroy; override;
  180.     procedure Popup(X, Y: Integer); virtual;
  181.     property PopupComponent: TComponent read FPopupComponent write FPopupComponent;
  182.   published
  183.     property Alignment: TPopupAlignment read FAlignment write FAlignment default paLeft;
  184.     property AutoPopup: Boolean read FAutoPopup write FAutoPopup default True;
  185.     property HelpContext: THelpContext read GetHelpContext write SetHelpContext default 0;
  186.     property OnPopup: TNotifyEvent read FOnPopup write FOnPopup;
  187.   end;
  188.  
  189. function ShortCut(Key: Word; Shift: TShiftState): TShortCut;
  190. procedure ShortCutToKey(ShortCut: TShortCut; var Key: Word; var Shift: TShiftState);
  191. function ShortCutToText(ShortCut: TShortCut): string;
  192. function TextToShortCut(Text: string): TShortCut;
  193.  
  194. function NewMenu(Owner: TComponent; const AName: string; Items: array of TMenuItem): TMainMenu;
  195. function NewPopupMenu(Owner: TComponent; const AName: string;
  196.   Alignment: TPopupAlignment; AutoPopup: Boolean; Items: array of TMenuitem): TPopupMenu;
  197. function NewSubMenu(const ACaption: string; hCtx: Word; const AName: string;
  198.   Items: array of TMenuItem): TMenuItem;
  199. function NewItem(const ACaption: string; AShortCut: TShortCut;
  200.   AChecked, AEnabled: Boolean; AOnClick: TNotifyEvent; hCtx: Word;
  201.   const AName: string): TMenuItem;
  202. function NewLine: TMenuItem;
  203.  
  204. implementation
  205.  
  206. uses Controls, Forms, Consts;
  207.  
  208. procedure Error(const S: string);
  209. begin
  210.   raise EMenuError.Create(S);
  211. end;
  212.  
  213. procedure IndexError;
  214. begin
  215.   Error(LoadStr(SMenuIndexError));
  216. end;
  217.  
  218. { TShortCut processing routines }
  219.  
  220. function ShortCut(Key: Word; Shift: TShiftState): TShortCut;
  221. begin
  222.   Result := 0;
  223.   if WordRec(Key).Hi <> 0 then Exit;
  224.   Result := Key;
  225.   if ssShift in Shift then Inc(Result, scShift);
  226.   if ssCtrl in Shift then Inc(Result, scCtrl);
  227.   if ssAlt in Shift then Inc(Result, scAlt);
  228. end;
  229.  
  230. procedure ShortCutToKey(ShortCut: TShortCut; var Key: Word; var Shift: TShiftState);
  231. begin
  232.   Key := ShortCut and not (scShift + scCtrl + scAlt);
  233.   Shift := [];
  234.   if ShortCut and scShift <> 0 then Include(Shift, ssShift);
  235.   if ShortCut and scCtrl <> 0 then Include(Shift, ssCtrl);
  236.   if ShortCut and scAlt <> 0 then Include(Shift, ssAlt);
  237. end;
  238.  
  239. type
  240.   TMenuKeyCap = (mkcBkSp, mkcTab, mkcEsc, mkcEnter, mkcSpace, mkcPgUp,
  241.     mkcPgDn, mkcEnd, mkcHome, mkcLeft, mkcUp, mkcRight, mkcDown, mkcIns,
  242.     mkcDel, mkcShift, mkcCtrl, mkcAlt);
  243.  
  244. const
  245.   MenuKeyCapIDs: array[TMenuKeyCap] of Word = (
  246.     SmkcBkSp, SmkcTab, SmkcEsc, SmkcEnter, SmkcSpace, SmkcPgUp,
  247.     SmkcPgDn, SmkcEnd, SmkcHome, SmkcLeft, SmkcUp, SmkcRight,
  248.     SmkcDown, SmkcIns, SmkcDel, SmkcShift, SmkcCtrl, SmkcAlt);
  249.  
  250. var
  251.   MenuKeyCaps: array[TMenuKeyCap] of string;
  252.  
  253. procedure LoadStrings;
  254. var
  255.   I: TMenuKeyCap;
  256. begin
  257.   for I := Low(TMenuKeyCap) to High(TMenuKeyCap) do
  258.     MenuKeyCaps[I] := LoadStr(MenuKeyCapIDs[I]);
  259. end;
  260.  
  261. function GetSpecialName(ShortCut: TShortCut): string;
  262. var
  263.   ScanCode: Integer;
  264.   KeyName: array[0..255] of Char;
  265. begin
  266.   Result := '';
  267.   ScanCode := MapVirtualKey(WordRec(ShortCut).Lo, 0) shl 16;
  268.   if ScanCode <> 0 then
  269.   begin
  270.     GetKeyNameText(ScanCode, KeyName, SizeOf(KeyName));
  271.     if (KeyName[1] = #0) and (KeyName[0] <> #0) then
  272.       GetSpecialName := KeyName;
  273.   end;
  274. end;
  275.  
  276. function ShortCutToText(ShortCut: TShortCut): string;
  277. var
  278.   Name: string;
  279. begin
  280.   case WordRec(ShortCut).Lo of
  281.     $08, $09:
  282.       Name := MenuKeyCaps[TMenuKeyCap(Ord(mkcBkSp) + WordRec(ShortCut).Lo - $08)];
  283.     $0D: Name := MenuKeyCaps[mkcEnter];
  284.     $1B: Name := MenuKeyCaps[mkcEsc];
  285.     $20..$28:
  286.       Name := MenuKeyCaps[TMenuKeyCap(Ord(mkcSpace) + WordRec(ShortCut).Lo - $20)];
  287.     $2D..$2E:
  288.       Name := MenuKeyCaps[TMenuKeyCap(Ord(mkcIns) + WordRec(ShortCut).Lo - $2D)];
  289.     $30..$39: Name := Chr(WordRec(ShortCut).Lo - $30 + Ord('0'));
  290.     $41..$5A: Name := Chr(WordRec(ShortCut).Lo - $41 + Ord('A'));
  291.     $60..$69: Name := Chr(WordRec(ShortCut).Lo - $60 + Ord('0'));
  292.     $70..$87: Name := 'F' + IntToStr(WordRec(ShortCut).Lo - $6F);
  293.   else
  294.     Name := GetSpecialName(ShortCut);
  295.   end;
  296.   if Name <> '' then
  297.   begin
  298.     Result := '';
  299.     if ShortCut and scShift <> 0 then Result := Result + MenuKeyCaps[mkcShift];
  300.     if ShortCut and scCtrl <> 0 then Result := Result + MenuKeyCaps[mkcCtrl];
  301.     if ShortCut and scAlt <> 0 then Result := Result + MenuKeyCaps[mkcAlt];
  302.     Result := Result + Name;
  303.   end
  304.   else Result := '';
  305. end;
  306.  
  307. { This function is *very* slow.  Use sparingly.  Return 0 if no VK code was
  308.   found for the text }
  309.  
  310. function TextToShortCut(Text: string): TShortCut;
  311.  
  312.   { If the front of Text is equal to Front then remove the matching piece
  313.     from Text and return True, otherwise return False }
  314.  
  315.   function CompareFront(var Text: string; const Front: string): Boolean;
  316.   begin
  317.     Result := False;
  318.     if CompareText(Copy(Text, 1, Length(Front)), Front) = 0 then
  319.     begin
  320.       Result := True;
  321.       Delete(Text, 1, Length(Front));
  322.     end;
  323.   end;
  324.  
  325. var
  326.   Key: TShortCut;
  327.   Shift: TShortCut;
  328. begin
  329.   Result := 0;
  330.   Shift := 0;
  331.   while True do
  332.   begin
  333.     if CompareFront(Text, MenuKeyCaps[mkcShift]) then Shift := Shift or scShift
  334.     else if CompareFront(Text, '^') then Shift := Shift or scCtrl
  335.     else if CompareFront(Text, MenuKeyCaps[mkcCtrl]) then Shift := Shift or scCtrl
  336.     else if CompareFront(Text, MenuKeyCaps[mkcAlt]) then Shift := Shift or scAlt
  337.     else Break;
  338.   end;
  339.   if Text = '' then Exit;
  340.   for Key := $08 to $255 do { Copy range from table in ShortCutToText }
  341.     if AnsiCompareText(Text, ShortCutToText(Key)) = 0 then
  342.     begin
  343.       Result := Key or Shift;
  344.       Exit;
  345.     end;
  346. end;
  347.  
  348. { Menu command managment }
  349.  
  350. var
  351.   CommandPool: TBits;
  352.  
  353. function UniqueCommand: Word;
  354. begin
  355.   Result := CommandPool.OpenBit;
  356.   CommandPool[Result] := True;
  357. end;
  358.  
  359. { Used to populate or merge menus }
  360.  
  361. procedure IterateMenus(Func: Pointer; Menu1, Menu2: TMenuItem);
  362. var
  363.   I, J: Integer;
  364.   IIndex, JIndex: Byte;
  365.   Menu1Size, Menu2Size: Integer;
  366.   Done: Boolean;
  367.  
  368.   function Iterate(var I: Integer; MenuItem: TMenuItem; AFunc: Pointer): Boolean;
  369.   var
  370.     Item: TMenuItem;
  371.   begin
  372.     if MenuItem = nil then Exit;
  373.     Result := False;
  374.     while not Result and (I < MenuItem.Count) do
  375.     begin
  376.       Item := MenuItem[I];
  377.       if Item.GroupIndex > IIndex then Break;
  378.       asm
  379.                 MOV     EAX,Item
  380.                 MOV     EDX,[EBP+8]
  381.                 PUSH    DWORD PTR [EDX]
  382.                 CALL    DWORD PTR AFunc
  383.                 ADD     ESP,4
  384.                 MOV     Result,AL
  385.       end;
  386.       Inc(I);
  387.     end;
  388.   end;
  389.  
  390. begin
  391.   I := 0;
  392.   J := 0;
  393.   Menu1Size := 0;
  394.   Menu2Size := 0;
  395.   if Menu1 <> nil then Menu1Size := Menu1.Count;
  396.   if Menu2 <> nil then Menu2Size := Menu2.Count;
  397.   Done := False;
  398.   while not Done and ((I < Menu1Size) or (J < Menu2Size)) do
  399.   begin
  400.     IIndex := High(Byte);
  401.     JIndex := High(Byte);
  402.     if (I < Menu1Size) then IIndex := Menu1[I].GroupIndex;
  403.     if (J < Menu2Size) then JIndex := Menu2[J].GroupIndex;
  404.     if IIndex <= JIndex then Done := Iterate(I, Menu1, Func)
  405.     else
  406.     begin
  407.       IIndex := JIndex;
  408.       Done := Iterate(J, Menu2, Func);
  409.     end;
  410.     while (I < Menu1Size) and (Menu1[I].GroupIndex <= IIndex) do Inc(I);
  411.     while (J < Menu2Size) and (Menu2[J].GroupIndex <= IIndex) do Inc(J);
  412.   end;
  413. end;
  414.  
  415. { TMenuItem }
  416.  
  417. constructor TMenuItem.Create(AOwner: TComponent);
  418. begin
  419.   inherited Create(AOwner);
  420.   FVisible := True;
  421.   FEnabled := True;
  422.   FCommand := UniqueCommand;
  423. end;
  424.  
  425. destructor TMenuItem.Destroy;
  426. begin
  427.   if FParent <> nil then
  428.   begin
  429.     FParent.Remove(Self);
  430.     FParent := nil;
  431.   end;
  432.   if FHandle <> 0 then
  433.   begin
  434.     MergeWith(nil);
  435.     DestroyMenu(FHandle);
  436.     ClearHandles;
  437.   end;
  438.   while Count > 0 do Items[0].Free;
  439.   FItems.Free;
  440.   if FCommand <> 0 then CommandPool[FCommand] := False;
  441.   inherited Destroy;
  442. end;
  443.  
  444. procedure TMenuItem.ClearHandles;
  445.  
  446.   procedure Clear(Item: TMenuItem);
  447.   var
  448.     I: Integer;
  449.   begin
  450.     with Item do
  451.     begin
  452.       FHandle := 0;
  453.       for I := 0 to GetCount - 1 do Clear(FItems[I]);
  454.     end;
  455.   end;
  456.  
  457. begin
  458.   Clear(Self);
  459. end;
  460.  
  461. const
  462.   Checks: array[Boolean] of LongInt = (MF_UNCHECKED, MF_CHECKED);
  463.   Enables: array[Boolean] of LongInt = (MF_DISABLED or MF_GRAYED, MF_ENABLED);
  464.   Breaks: array[TMenuBreak] of Longint = (0, MF_MENUBREAK, MF_MENUBARBREAK);
  465.   Separators: array[Boolean] of LongInt = (MF_STRING, MF_SEPARATOR);
  466.  
  467. procedure TMenuItem.AppendTo(Menu: HMENU);
  468. const
  469.   IBreaks: array[TMenuBreak] of Longint = (MFT_STRING, MFT_MENUBREAK, MFT_MENUBARBREAK);
  470.   IChecks: array[Boolean] of Longint = (MFS_UNCHECKED, MFS_CHECKED);
  471.   IDefaults: array[Boolean] of Longint = (0, MFS_DEFAULT);
  472.   IEnables: array[Boolean] of Longint = (MFS_DISABLED or MFS_GRAYED, MFS_ENABLED);
  473.   IRadios: array[Boolean] of Longint = (MFT_STRING, MFT_RADIOCHECK);
  474.   ISeparators: array[Boolean] of Longint = (MFT_STRING, MFT_SEPARATOR);
  475. var
  476.   MenuItemInfo: TMenuItemInfo;
  477.   Caption: string;
  478.   NewFlags: Integer;
  479. begin
  480.   if FVisible then
  481.   begin
  482.     Caption := FCaption;
  483.     if GetCount > 0 then MenuItemInfo.hSubMenu := GetHandle
  484.     else if (FShortCut <> scNone) and ((Parent = nil) or
  485.       (Parent.Parent <> nil) or not (Parent.Owner is TMainMenu)) then
  486.       Caption := Caption + #9 + ShortCutToText(FShortCut);
  487.     if Lo(GetVersion) >= 4 then
  488.     begin
  489.       MenuItemInfo.cbSize := SizeOf(TMenuItemInfo);
  490.       MenuItemInfo.fMask := MIIM_CHECKMARKS or MIIM_DATA or MIIM_ID or
  491.         MIIM_STATE or MIIM_SUBMENU or MIIM_TYPE;
  492.       MenuItemInfo.fType := IRadios[FRadioItem] or IBreaks[FBreak] or
  493.         ISeparators[FCaption = '-'];
  494.       MenuItemInfo.fState := IChecks[FChecked] or IEnables[FEnabled]
  495.         or IDefaults[FDefault];
  496.       MenuItemInfo.wID := Command;
  497.       MenuItemInfo.hSubMenu := 0;
  498.       MenuItemInfo.hbmpChecked := 0;
  499.       MenuItemInfo.hbmpUnchecked := 0;
  500.       MenuItemInfo.dwTypeData := PChar(Caption);
  501.       if GetCount > 0 then MenuITemInfo.hSubMenu := GetHandle;
  502.       InsertMenuItem(Menu, -1, True, MenuItemInfo);
  503.     end
  504.     else
  505.     begin
  506.       NewFlags := Breaks[FBreak] or Checks[FChecked] or Enables[FEnabled] or
  507.         Separators[FCaption = '-'] or MF_BYPOSITION;
  508.       if GetCount > 0 then
  509.         InsertMenu(Menu, -1, MF_POPUP or NewFlags, GetHandle,
  510.           PChar(FCaption))
  511.       else
  512.         InsertMenu(Menu, -1, NewFlags, Command, PChar(Caption));
  513.     end;
  514.   end;
  515. end;
  516.  
  517. procedure TMenuItem.PopulateMenu;
  518.  
  519.   function AddIn(MenuItem: TMenuItem): Boolean;
  520.   begin
  521.     MenuItem.AppendTo(FHandle);
  522.     Result := False;
  523.   end;
  524.  
  525. begin
  526.   IterateMenus(@AddIn, FMerged, Self);
  527. end;
  528.  
  529. procedure TMenuItem.ReadShortCutText(Reader: TReader);
  530. begin
  531.   ShortCut := TextToShortCut(Reader.ReadString);
  532. end;
  533.  
  534. procedure TMenuItem.MergeWith(Menu: TMenuItem);
  535. begin
  536.   if FMerged <> Menu then
  537.   begin
  538.     FMerged := Menu;
  539.     RebuildHandle;
  540.   end;
  541. end;
  542.  
  543. procedure TMenuItem.RebuildHandle;
  544. begin
  545.   while GetMenuItemCount(Handle) > 0 do RemoveMenu(Handle, 0, MF_BYPOSITION);
  546.   PopulateMenu;
  547.   MenuChanged(False);
  548. end;
  549.  
  550. procedure TMenuItem.VerifyGroupIndex(Position: Integer; Value: Byte);
  551. var
  552.   I: Integer;
  553. begin
  554.   for I := 0 to GetCount - 1 do
  555.     if I < Position then
  556.     begin
  557.       if Items[I].GroupIndex > Value then Error(LoadStr(SGroupIndexTooLow))
  558.     end
  559.     else
  560.       { Ripple change to menu items at Position and after }
  561.       if Items[I].GroupIndex < Value then Items[I].FGroupIndex := Value;
  562. end;
  563.  
  564. procedure TMenuItem.WriteShortCutText(Writer: TWriter);
  565. begin
  566.   {Writer.WriteString(ShortCutToText(ShortCut));}
  567. end;
  568.  
  569. function TMenuItem.GetHandle: HMENU;
  570. begin
  571.   if FHandle = 0 then
  572.   begin
  573.     if Owner is TPopupMenu then
  574.       FHandle := CreatePopupMenu
  575.     else
  576.       FHandle := CreateMenu;
  577.     if FHandle = 0 then raise EMenuError.CreateRes(SOutOfResources);
  578.     PopulateMenu;
  579.   end;
  580.   Result := FHandle;
  581. end;
  582.  
  583. procedure TMenuItem.DefineProperties(Filer: TFiler);
  584. begin
  585.   inherited DefineProperties(Filer);
  586.   Filer.DefineProperty('ShortCutText', ReadShortCutText, WriteShortCutText, False);
  587. end;
  588.  
  589. function TMenuItem.HasParent: Boolean;
  590. begin
  591.   Result := True;
  592. end;
  593.  
  594. procedure TMenuItem.SetBreak(Value: TMenuBreak);
  595. begin
  596.   if FBreak <> Value then
  597.   begin
  598.     FBreak := Value;
  599.     MenuChanged(True);
  600.   end;
  601. end;
  602.  
  603. procedure TMenuItem.SetCaption(const Value: string);
  604. begin
  605.   if FCaption <> Value then
  606.   begin
  607.     FCaption := Value;
  608.     MenuChanged(True);
  609.   end;
  610. end;
  611.  
  612. procedure TMenuItem.SetChecked(Value: Boolean);
  613. var
  614.   I: Integer;
  615.   Item: TMenuItem;
  616. begin
  617.   if FChecked <> Value then
  618.   begin
  619.     if FRadioItem and (GroupIndex <> 0) and (FParent <> nil) then
  620.       for I := 0 to FParent.Count - 1 do
  621.       begin
  622.         Item := FParent[I];
  623.         if (Item <> Self) and Item.FRadioItem and (Item.GroupIndex = GroupIndex) then
  624.           Item.Checked := False;
  625.       end;
  626.     FChecked := Value;
  627.     if FParent <> nil then
  628.       CheckMenuItem(FParent.Handle, FCommand, MF_BYCOMMAND or Checks[Value]);
  629.   end;
  630. end;
  631.  
  632. procedure TMenuItem.SetEnabled(Value: Boolean);
  633. begin
  634.   if FEnabled <> Value then
  635.   begin
  636.     FEnabled := Value;
  637.     if (Win32Platform = VER_PLATFORM_WIN32_NT) and (Count <> 0) then
  638.       MenuChanged(True)
  639.     else
  640.     begin
  641.       if FParent <> nil then
  642.         EnableMenuItem(FParent.Handle, FCommand, MF_BYCOMMAND or Enables[Value]);
  643.       MenuChanged(False);
  644.     end;
  645.   end;
  646. end;
  647.  
  648. procedure TMenuItem.SetGroupIndex(Value: Byte);
  649. begin
  650.   if FGroupIndex <> Value then
  651.   begin
  652.     if Parent <> nil then Parent.VerifyGroupIndex(Parent.IndexOf(Self), Value);
  653.     FGroupIndex := Value;
  654.   end;
  655. end;
  656.  
  657. function TMenuItem.GetCount: Integer;
  658. begin
  659.   if FItems = nil then Result := 0
  660.   else Result := FItems.Count;
  661. end;
  662.  
  663. function TMenuItem.GetItem(Index: Integer): TMenuItem;
  664. begin
  665.   if FItems = nil then IndexError;
  666.   Result := FItems[Index];
  667. end;
  668.  
  669. procedure TMenuItem.SetShortCut(Value: TShortCut);
  670. begin
  671.   FShortCut := Value;
  672.   MenuChanged(True);
  673. end;
  674.  
  675. procedure TMenuItem.SetVisible(Value: Boolean);
  676. begin
  677.   FVisible := Value;
  678.   MenuChanged(True);
  679. end;
  680.  
  681. function TMenuItem.GetMenuIndex: Integer;
  682. begin
  683.   Result := -1;
  684.   if FParent <> nil then Result := FParent.IndexOf(Self);
  685. end;
  686.  
  687. procedure TMenuItem.SetMenuIndex(Value: Integer);
  688. var
  689.   Parent: TMenuItem;
  690.   Count: Integer;
  691. begin
  692.   if FParent <> nil then
  693.   begin
  694.     Count := FParent.Count;
  695.     if Value < 0 then Value := 0;
  696.     if Value >= Count then Value := Count - 1;
  697.     if Value <> MenuIndex then
  698.     begin
  699.       Parent := FParent;
  700.       Parent.Remove(Self);
  701.       Parent.Insert(Value, Self);
  702.     end;
  703.   end;
  704. end;
  705.  
  706. procedure TMenuItem.GetChildren(Proc: TGetChildProc);
  707. var
  708.   I: Integer;
  709. begin
  710.   for I := 0 to Count - 1 do Proc(Items[I]);
  711. end;
  712.  
  713. procedure TMenuItem.SetChildOrder(Child: TComponent; Order: Integer);
  714. begin
  715.   (Child as TMenuItem).MenuIndex := Order;
  716. end;
  717.  
  718. procedure TMenuItem.SetDefault(Value: Boolean);
  719. var
  720.   I: Integer;
  721. begin
  722.   if FDefault <> Value then
  723.   begin
  724.     if Value and (FParent <> nil) then
  725.       for I := 0 to FParent.Count - 1 do
  726.         if FParent[I].Default then FParent[I].FDefault := False; 
  727.     FDefault := Value;
  728.     MenuChanged(True);
  729.   end;
  730. end;
  731.  
  732. procedure TMenuItem.Insert(Index: Integer; Item: TMenuItem);
  733. begin
  734.   if Item.FParent <> nil then
  735.     raise EMenuError.CreateRes(SMenuReinserted);
  736.   if FItems = nil then FItems := TList.Create;
  737.   if (Index - 1 >= 0) and (Index - 1 < FItems.Count) then
  738.     if Item.GroupIndex < TMenuItem(FItems[Index - 1]).GroupIndex then
  739.       Item.GroupIndex := TMenuItem(FItems[Index - 1]).GroupIndex;
  740.   VerifyGroupIndex(Index, Item.GroupIndex);
  741.   FItems.Insert(Index, Item);
  742.   Item.FParent := Self;
  743.   Item.FOnChange := SubItemChanged;
  744.   if FHandle <> 0 then RebuildHandle;
  745.   MenuChanged(True);
  746. end;
  747.  
  748. procedure TMenuItem.Delete(Index: Integer);
  749. var
  750.   Cur: TMenuItem;
  751. begin
  752.   if (Index < 0) or (FItems = nil) or (Index >= GetCount) then IndexError;
  753.   Cur := FItems[Index];
  754.   FItems.Delete(Index);
  755.   Cur.FParent := nil;
  756.   Cur.FOnChange := nil;
  757.   if FHandle <> 0 then RebuildHandle;
  758.   MenuChanged(True);
  759. end;
  760.  
  761. procedure TMenuItem.Click;
  762. begin
  763.   if FEnabled and Assigned(FOnClick) then FOnClick(Self);
  764. end;
  765.  
  766. function TMenuItem.IndexOf(Item: TMenuItem): Integer;
  767. begin
  768.   Result := -1;
  769.   if FItems <> nil then Result := FItems.IndexOf(Item);
  770. end;
  771.  
  772. procedure TMenuItem.Add(Item: TMenuItem);
  773. begin
  774.   Insert(GetCount, Item);
  775. end;
  776.  
  777. procedure TMenuItem.Remove(Item: TMenuItem);
  778. var
  779.   I: Integer;
  780. begin
  781.   I := IndexOf(Item);
  782.   if I = -1 then raise EMenuError.CreateRes(SMenuNotFound);
  783.   Delete(I);
  784. end;
  785.  
  786. procedure TMenuItem.MenuChanged(Rebuild: Boolean);
  787. begin
  788.   if Assigned(FOnChange) then FOnChange(Self, Rebuild);
  789. end;
  790.  
  791. procedure TMenuItem.SubItemChanged(Sender: TObject; Rebuild: Boolean);
  792. begin
  793.   if Rebuild and (FHandle <> 0) then RebuildHandle;
  794.   if Parent <> nil then Parent.SubItemChanged(Self, False)
  795.   else if Owner is TMainMenu then TMainMenu(Owner).ItemChanged;
  796. end;
  797.  
  798. function TMenuItem.GetParentComponent: TComponent;
  799. begin
  800.   if (FParent <> nil) and (FParent.FMenu <> nil) then
  801.     Result := FParent.FMenu else
  802.     Result := FParent;
  803. end;
  804.  
  805. procedure TMenuItem.SetParentComponent(Value: TComponent);
  806. begin
  807.   if FParent <> nil then FParent.Remove(Self);
  808.   if Value <> nil then
  809.     if Value is TMenu then
  810.       TMenu(Value).Items.Add(Self)
  811.     else if Value is TMenuItem then
  812.       TMenuItem(Value).Add(Self);
  813. end;
  814.  
  815. procedure TMenuItem.SetRadioItem(Value: Boolean);
  816. begin
  817.   if FRadioItem <> Value then
  818.   begin
  819.     FRadioItem := Value;
  820.     MenuChanged(True);
  821.   end;
  822. end;
  823.  
  824. { TMenu }
  825.  
  826. constructor TMenu.Create(AOwner: TComponent);
  827. begin
  828.   FItems := TMenuItem.Create(Self);
  829.   FItems.FOnChange := MenuChanged;
  830.   FItems.FMenu := Self;
  831.   inherited Create(AOwner);
  832. end;
  833.  
  834. destructor TMenu.Destroy;
  835. begin
  836.   FItems.Free;
  837.   inherited Destroy;
  838. end;
  839.  
  840. procedure TMenu.GetChildren(Proc: TGetChildProc);
  841. begin
  842.   FItems.GetChildren(Proc);
  843. end;
  844.  
  845. function TMenu.GetHandle: HMENU;
  846. begin
  847.   Result := FItems.GetHandle;
  848. end;
  849.  
  850. procedure TMenu.SetChildOrder(Child: TComponent; Order: Integer);
  851. begin
  852.   FItems.SetChildOrder(Child, Order);
  853. end;
  854.  
  855. function TMenu.FindItem(Value: Integer; Kind: TFindItemKind): TMenuItem;
  856. var
  857.   FoundItem: TMenuItem;
  858.  
  859.   function Find(Item: TMenuItem): Boolean;
  860.   var
  861.     I: Integer;
  862.   begin
  863.     Result := False;
  864.     if ((Kind = fkCommand) and (Value = Item.Command)) or
  865.       ((Kind = fkHandle) and (Value = Item.FHandle)) or
  866.       ((Kind = fkShortCut) and (Value = Item.ShortCut)) then
  867.     begin
  868.       FoundItem := Item;
  869.       Result := True;
  870.       Exit;
  871.     end
  872.     else
  873.       for I := 0 to Item.GetCount - 1 do
  874.         if Find(Item[I]) then
  875.         begin
  876.           Result := True;
  877.           Exit;
  878.         end;
  879.   end;
  880.  
  881. begin
  882.   FoundItem := nil;
  883.   IterateMenus(@Find, Items.FMerged, Items);
  884.   Result := FoundItem;
  885. end;
  886.  
  887. function TMenu.GetHelpContext(Value: Word; ByCommand: Boolean): THelpContext;
  888. var
  889.   Item: TMenuItem;
  890.   Kind: TFindItemKind;
  891. begin
  892.   Result := 0;
  893.   Kind := fkHandle;
  894.   if ByCommand then Kind := fkCommand;
  895.   Item := FindItem(Value, Kind);
  896.   while (Item <> nil) and (Item.FHelpContext = 0) do
  897.     Item := Item.FParent;
  898.   if Item <> nil then Result := Item.FHelpContext;
  899. end;
  900.  
  901. function TMenu.DispatchCommand(ACommand: Word): Boolean;
  902. var
  903.   Item: TMenuItem;
  904. begin
  905.   Result := False;
  906.   Item := FindItem(ACommand, fkCommand);
  907.   if Item <> nil then
  908.   begin
  909.     Item.Click;
  910.     Result := True;
  911.   end;
  912. end;
  913.  
  914. function TMenu.DispatchPopup(AHandle: HMENU): Boolean;
  915. var
  916.   Item: TMenuItem;
  917. begin
  918.   Result := False;
  919.   Item := FindItem(AHandle, fkHandle);
  920.   if Item <> nil then
  921.   begin
  922.     Item.Click;
  923.     Result := True;
  924.   end;
  925. end;
  926.  
  927. function TMenu.IsShortCut(var Message: TWMKey): Boolean;
  928. type
  929.   TClickResult = (crDisabled, crClicked, crShortCutMoved);
  930. const
  931.   AltMask = $20000000;
  932. var
  933.   ShortCut: TShortCut;
  934.   ShortCutItem: TMenuItem;
  935.   ClickResult: TClickResult;
  936.  
  937.   function DoClick(Item: TMenuItem): TClickResult;
  938.   begin
  939.     Result := crClicked;
  940.     if Item.Parent <> nil then Result := DoClick(Item.Parent);
  941.     if Result = crClicked then
  942.       if Item.Enabled then
  943.         try
  944.           Item.Click;
  945.           if ShortCutItem.ShortCut <> ShortCut then
  946.             Result := crShortCutMoved;
  947.         except
  948.           Application.HandleException(Self);
  949.         end
  950.       else Result := crDisabled;
  951.   end;
  952.  
  953. begin
  954.   Result := False;
  955.   if FWindowHandle <> 0 then
  956.   begin
  957.     ShortCut := Byte(Message.CharCode);
  958.     if GetKeyState(VK_SHIFT) < 0 then Inc(ShortCut, scShift);
  959.     if GetKeyState(VK_CONTROL) < 0 then Inc(ShortCut, scCtrl);
  960.     if Message.KeyData and AltMask <> 0 then Inc(ShortCut, scAlt);
  961.     repeat
  962.       ClickResult := crDisabled;
  963.       ShortCutItem := FindItem(ShortCut, fkShortCut);
  964.       if ShortCutItem <> nil then ClickResult := DoClick(ShortCutItem);
  965.     until ClickResult <> crShortCutMoved;
  966.     Result := ShortCutItem <> nil;
  967.   end;
  968. end;
  969.  
  970. function TMenu.UpdateImage: Boolean;
  971. var
  972.   Image: array[0..511] of Char;
  973.  
  974.   procedure BuildImage(Menu: HMENU);
  975.   var
  976.     P, ImageEnd: PChar;
  977.     I, C: Integer;
  978.     State: Word;
  979.   begin
  980.     C := GetMenuItemCount(Menu);
  981.     P := Image;
  982.     ImageEnd := @Image[SizeOf(Image) - 5];
  983.     I := 0;
  984.     while (I < C) and (P < ImageEnd) do
  985.     begin
  986.       GetMenuString(Menu, I, P, ImageEnd - P, MF_BYPOSITION);
  987.       P := StrEnd(P);
  988.       State := GetMenuState(Menu, I, MF_BYPOSITION);
  989.       if State and MF_DISABLED <> 0 then P := StrECopy(P, '$');
  990.       if State and MF_MENUBREAK <> 0 then P := StrECopy(P, '@');
  991.       if State and MF_GRAYED <> 0 then P := StrECopy(P, '#');
  992.       P := StrECopy(P, ';');
  993.       Inc(I);
  994.     end;
  995.   end;
  996.  
  997. begin
  998.   Result := False;
  999.   Image[0] := #0;
  1000.   if FWindowHandle <> 0 then BuildImage(Handle);
  1001.   if (FMenuImage = '') or (StrComp(PChar(FMenuImage), Image) <> 0) then
  1002.   begin
  1003.     Result := True;
  1004.     FMenuImage := Image;
  1005.   end;
  1006. end;
  1007.  
  1008. procedure TMenu.SetWindowHandle(Value: HWND);
  1009. begin
  1010.   FWindowHandle := Value;
  1011.   UpdateImage;
  1012. end;
  1013.  
  1014. procedure TMenu.MenuChanged(Sender: TObject; Rebuild: Boolean);
  1015. begin
  1016. end;
  1017.  
  1018. { TMainMenu }
  1019.  
  1020. procedure TMainMenu.SetAutoMerge(Value: Boolean);
  1021. begin
  1022.   if FAutoMerge <> Value then
  1023.   begin
  1024.     FAutoMerge := Value;
  1025.     if FWindowHandle <> 0 then
  1026.       SendMessage(FWindowHandle, CM_MENUCHANGED, 0, 0);
  1027.   end;
  1028. end;
  1029.  
  1030. procedure TMainMenu.MenuChanged(Sender: TObject; Rebuild: Boolean);
  1031. begin
  1032.   if (FWindowHandle <> 0) and UpdateImage then DrawMenuBar(FWindowHandle);
  1033. end;
  1034.  
  1035. procedure TMainMenu.Merge(Menu: TMainMenu);
  1036. begin
  1037.   if Menu <> nil then
  1038.     FItems.MergeWith(Menu.FItems) else
  1039.     FItems.MergeWith(nil);
  1040. end;
  1041.  
  1042. procedure TMainMenu.Unmerge(Menu: TMainMenu);
  1043. begin
  1044.   if (Menu <> nil) and (FItems.FMerged = Menu.FItems) then
  1045.     FItems.MergeWith(nil);
  1046. end;
  1047.  
  1048. procedure TMainMenu.ItemChanged;
  1049. begin
  1050.   MenuChanged(nil, False);
  1051.   if FWindowHandle <> 0 then
  1052.     SendMessage(FWindowHandle, CM_MENUCHANGED, 0, 0);
  1053. end;
  1054.  
  1055. function TMainMenu.GetHandle: HMENU;
  1056. begin
  1057.   if FOle2Menu <> 0 then
  1058.     Result := FOle2Menu else
  1059.     Result := inherited GetHandle;
  1060. end;
  1061.  
  1062. procedure TMainMenu.GetOle2AcceleratorTable(var AccelTable: HAccel;
  1063.   var AccelCount: Integer; Groups: array of Integer);
  1064. var
  1065.   NumAccels: Integer;
  1066.   AccelList, AccelPtr: PAccel;
  1067.  
  1068.   procedure ProcessAccels(Item: TMenuItem);
  1069.   var
  1070.     I: Integer;
  1071.     Virt: Byte;
  1072.   begin
  1073.     if Item.ShortCut <> 0 then
  1074.       if AccelPtr <> nil then
  1075.       begin
  1076.         Virt := FNOINVERT or FVIRTKEY;
  1077.         if Item.ShortCut and scCtrl <> 0 then Virt := Virt or FCONTROL;
  1078.         if Item.ShortCut and scAlt <> 0 then Virt := Virt or FALT;
  1079.         if Item.ShortCut and scShift <> 0 then Virt := Virt or FSHIFT;
  1080.         AccelPtr^.fVirt := Virt;
  1081.         AccelPtr^.key := Item.ShortCut and $FF;
  1082.         AccelPtr^.cmd := Item.Command;
  1083.         Inc(AccelPtr);
  1084.       end else
  1085.         Inc(NumAccels)
  1086.     else
  1087.       for I := 0 to Item.GetCount - 1 do ProcessAccels(Item[I]);
  1088.   end;
  1089.  
  1090.   function ProcessAccelItems(Item: TMenuItem): Boolean;
  1091.   var
  1092.     I: Integer;
  1093.   begin
  1094.     for I := 0 to High(Groups) do
  1095.       if Item.GroupIndex = Groups[I] then
  1096.       begin
  1097.         ProcessAccels(Item);
  1098.         Break;
  1099.       end;
  1100.     Result := False;
  1101.   end;
  1102.  
  1103. begin
  1104.   NumAccels := 0;
  1105.   AccelPtr := nil;
  1106.   IterateMenus(@ProcessAccelItems, Items.FMerged, Items);
  1107.   AccelTable := 0;
  1108.   if NumAccels <> 0 then
  1109.   begin
  1110.     GetMem(AccelList, NumAccels * SizeOf(TAccel));
  1111.     AccelPtr := AccelList;
  1112.     IterateMenus(@ProcessAccelItems, Items.FMerged, Items);
  1113.     AccelTable := CreateAcceleratorTable(AccelList^, NumAccels);
  1114.     FreeMem(AccelList);
  1115.   end;
  1116.   AccelCount := NumAccels;
  1117. end;
  1118.  
  1119. { Similar to regular TMenuItem.PopulateMenus except that it only adds
  1120.   the specified groups to the menu handle }
  1121.  
  1122. procedure TMainMenu.PopulateOle2Menu(SharedMenu: HMenu;
  1123.   Groups: array of Integer; var Widths: array of Longint);
  1124. var
  1125.   NumGroups: Integer;
  1126.   J: Integer;
  1127.  
  1128.   function AddOle2(Item: TMenuItem): Boolean;
  1129.   var
  1130.     I: Integer;
  1131.   begin
  1132.     for I := 0 to NumGroups do
  1133.     begin
  1134.       if Item.GroupIndex = Groups[I] then
  1135.       begin
  1136.         Inc(Widths[Item.GroupIndex]);
  1137.         Item.AppendTo(SharedMenu);
  1138.       end;
  1139.     end;
  1140.     Result := False;
  1141.   end;
  1142.  
  1143. begin
  1144.   NumGroups := High(Groups);
  1145.   for J := 0 to High(Widths) do Widths[J] := 0;
  1146.   IterateMenus(@AddOle2, Items.FMerged, Items);
  1147. end;
  1148.  
  1149. procedure TMainMenu.SetOle2MenuHandle(Handle: HMENU);
  1150. begin
  1151.   FOle2Menu := Handle;
  1152.   ItemChanged;
  1153. end;
  1154.  
  1155. { TPopupMenu }
  1156.  
  1157. type
  1158.   TPopupList = class(TList)
  1159.   private
  1160.     procedure WndProc(var Message: TMessage);
  1161.   public
  1162.     Window: HWND;
  1163.     procedure Add(Popup: TPopupMenu);
  1164.     procedure Remove(Popup: TPopupMenu);
  1165.   end;
  1166.  
  1167. var
  1168.   PopupList: TPopupList;
  1169.  
  1170. procedure TPopupList.WndProc(var Message: TMessage);
  1171. var
  1172.   I: Integer;
  1173.   MenuItem: TMenuItem;
  1174.   FindKind: TFindItemKind;
  1175.   ContextID: Integer;
  1176. begin
  1177.   try
  1178.     case Message.Msg of
  1179.       WM_COMMAND:
  1180.         for I := 0 to Count - 1 do
  1181.           if TPopupMenu(Items[I]).DispatchCommand(Message.wParam) then Exit;
  1182.       WM_INITMENUPOPUP:
  1183.         for I := 0 to Count - 1 do
  1184.           with TWMInitMenuPopup(Message) do
  1185.             if TPopupMenu(Items[I]).DispatchPopup(MenuPopup) then Exit;
  1186.       WM_MENUSELECT:
  1187.         with TWMMenuSelect(Message) do
  1188.         begin
  1189.           FindKind := fkCommand;
  1190.           if MenuFlag and MF_POPUP <> 0 then FindKind := fkHandle;
  1191.           for I := 0 to Count - 1 do
  1192.           begin
  1193.             MenuItem := TPopupMenu(Items[I]).FindItem(IDItem, FindKind);
  1194.             if MenuItem <> nil then
  1195.             begin
  1196.               Application.Hint := MenuItem.Hint;
  1197.               Exit;
  1198.             end;
  1199.           end;
  1200.           Application.Hint := '';
  1201.         end;
  1202.       WM_HELP:
  1203.         with PHelpInfo(Message.LParam)^ do
  1204.         begin
  1205.           for I := 0 to Count - 1 do
  1206.             if TPopupMenu(Items[I]).Handle = hItemHandle then
  1207.             begin
  1208.               ContextID := TMenu(Items[I]).GetHelpContext(iCtrlID, True);
  1209.               if ContextID = 0 then
  1210.                 ContextID := TMenu(Items[I]).GetHelpContext(hItemHandle, False);
  1211.               if Screen.ActiveForm = nil then Exit;
  1212.               if (biHelp in Screen.ActiveForm.BorderIcons) then
  1213.                 Application.HelpCommand(HELP_CONTEXTPOPUP, ContextID)
  1214.               else
  1215.                 Application.HelpContext(ContextID);
  1216.               Exit;
  1217.             end;
  1218.         end;
  1219.     end;
  1220.     with Message do Result := DefWindowProc(Window, Msg, wParam, lParam);
  1221.   except
  1222.     Application.HandleException(Self);
  1223.   end;
  1224. end;
  1225.  
  1226. procedure TPopupList.Add(Popup: TPopupMenu);
  1227. begin
  1228.   if Count = 0 then Window := AllocateHWnd(WndProc);
  1229.   inherited Add(Popup);
  1230. end;
  1231.  
  1232. procedure TPopupList.Remove(Popup: TPopupMenu);
  1233. begin
  1234.   inherited Remove(Popup);
  1235.   if Count = 0 then DeallocateHWnd(Window);
  1236. end;
  1237.  
  1238. constructor TPopupMenu.Create(AOwner: TComponent);
  1239. begin
  1240.   inherited Create(AOwner);
  1241.   FItems.OnClick := DoPopup;
  1242.   FWindowHandle := Application.Handle;
  1243.   FAutoPopup := True;
  1244.   PopupList.Add(Self);
  1245. end;
  1246.  
  1247. destructor TPopupMenu.Destroy;
  1248. begin
  1249.   PopupList.Remove(Self);
  1250.   inherited Destroy;
  1251. end;
  1252.  
  1253. procedure TPopupMenu.DoPopup(Item: TObject);
  1254. begin
  1255.   if Assigned(FOnPopup) then FOnPopup(Item);
  1256. end;
  1257.  
  1258. function TPopupMenu.GetHelpContext: THelpContext;
  1259. begin
  1260.   Result := FItems.HelpContext;
  1261. end;
  1262.  
  1263. procedure TPopupMenu.SetHelpContext(Value: THelpContext);
  1264. begin
  1265.   FItems.HelpContext := Value;
  1266. end;
  1267.  
  1268. procedure TPopupMenu.Popup(X, Y: Integer);
  1269. const
  1270.   Flags: array[TPopupAlignment] of Word = (TPM_LEFTALIGN, TPM_RIGHTALIGN,
  1271.     TPM_CENTERALIGN);
  1272. begin
  1273.   DoPopup(Self);
  1274.   TrackPopupMenu(FItems.Handle, Flags[FAlignment] or TPM_RIGHTBUTTON, X, Y,
  1275.     0 { reserved}, PopupList.Window, nil);
  1276. end;
  1277.  
  1278. { Menu building functions }
  1279.  
  1280. procedure InitMenuItems(AMenu: TMenu; Items: array of TMenuItem);
  1281. var
  1282.   I: Integer;
  1283.  
  1284.   procedure SetOwner(Item: TMenuItem);
  1285.   var
  1286.     I: Integer;
  1287.   begin
  1288.     if Item.Owner = nil then AMenu.Owner.InsertComponent(Item);
  1289.     for I := 0 to Item.Count - 1 do
  1290.       SetOwner(Item[I]);
  1291.   end;
  1292.  
  1293. begin
  1294.   for I := Low(Items) to High(Items) do
  1295.   begin
  1296.     SetOwner(Items[I]);
  1297.     AMenu.FItems.Add(Items[I]);
  1298.   end;
  1299. end;
  1300.  
  1301. function NewMenu(Owner: TComponent; const AName: string; Items: array of TMenuItem): TMainMenu;
  1302. begin
  1303.   Result := TMainMenu.Create(Owner);
  1304.   Result.Name := AName;
  1305.   InitMenuItems(Result, Items);
  1306. end;
  1307.  
  1308. function NewPopupMenu(Owner: TComponent; const AName: string;
  1309.   Alignment: TPopupAlignment; AutoPopup: Boolean; Items: array of TMenuItem): TPopupMenu;
  1310. begin
  1311.   Result := TPopupMenu.Create(Owner);
  1312.   Result.Name := AName;
  1313.   Result.AutoPopup := AutoPopup;
  1314.   Result.Alignment := Alignment;
  1315.   InitMenuItems(Result, Items);
  1316. end;
  1317.  
  1318. function NewSubMenu(const ACaption: string; hCtx: Word; const AName: string;
  1319.   Items: array of TMenuItem): TMenuItem;
  1320. var
  1321.   I: Integer;
  1322. begin
  1323.   Result := TMenuItem.Create(nil);
  1324.   for I := Low(Items) to High(Items) do
  1325.     Result.Add(Items[I]);
  1326.   Result.Caption := ACaption;
  1327.   Result.HelpContext := hCtx;
  1328.   Result.Name := AName;
  1329. end;
  1330.  
  1331. function NewItem(const ACaption: string; AShortCut: TShortCut;
  1332.   AChecked, AEnabled: Boolean; AOnClick: TNotifyEvent; hCtx: Word;
  1333.   const AName: string): TMenuItem;
  1334. begin
  1335.   Result := TMenuItem.Create(nil);
  1336.   with Result do
  1337.   begin
  1338.     Caption := ACaption;
  1339.     ShortCut := AShortCut;
  1340.     OnClick := AOnClick;
  1341.     HelpContext := hCtx;
  1342.     Checked := AChecked;
  1343.     Enabled := AEnabled;
  1344.     Name := AName;
  1345.   end;
  1346. end;
  1347.  
  1348. function NewLine: TMenuItem;
  1349. begin
  1350.   Result := TMenuItem.Create(nil);
  1351.   Result.Caption := '-';
  1352. end;
  1353.  
  1354. begin
  1355.   RegisterClasses([TMenuItem]);
  1356.   LoadStrings;
  1357.   CommandPool := TBits.Create;
  1358.   PopupList := TPopupList.Create;
  1359. end.
  1360.