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