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