Source/TntMenus.pas

   1
   2 {*****************************************************************************}
   3 {                                                                             }
   4 {    Tnt Delphi Unicode Controls                                              }
   5 {      http://www.tntware.com/delphicontrols/unicode/                         }
   6 {        Version: 2.3.0                                                       }
   7 {                                                                             }
   8 {    Copyright (c) 2002-2007, Troy Wolbrink (troy.wolbrink@tntware.com)       }
   9 {                                                                             }
  10 {*****************************************************************************}
  11
  12 unit TntMenus;
  13
  14 {$INCLUDE TntCompilers.inc}
  15
  16 interface
  17
  18 uses
  19   Windows, Classes, Menus, Graphics, Messages;
  20
  21 type
  22 {TNT-WARN TMenuItem}
  23   TTntMenuItem = class(TMenuItem{TNT-ALLOW TMenuItem})
  24   private
  25     FIgnoreMenuChanged: Boolean;
  26     FCaption: WideString;
  27     FHint: WideString;
  28     FKeyboardLayout: HKL;
  29     function GetCaption: WideString;
  30     procedure SetInheritedCaption(const Value: AnsiString);
  31     procedure SetCaption(const Value: WideString);
  32     function IsCaptionStored: Boolean;
  33     procedure UpdateMenuString(ParentMenu: TMenu);
  34     function GetAlignmentDrawStyle: Word;
  35     function MeasureItemTextWidth(ACanvas: TCanvas; const Text: WideString): Integer;
  36     function GetHint: WideString;
  37     procedure SetInheritedHint(const Value: AnsiString);
  38     procedure SetHint(const Value: WideString);
  39     function IsHintStored: Boolean;
  40   protected
  41     procedure DefineProperties(Filer: TFiler); override;
  42     function GetActionLinkClass: TMenuActionLinkClass; override;
  43     procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override;
  44     procedure MenuChanged(Rebuild: Boolean); override;
  45     procedure AdvancedDrawItem(ACanvas: TCanvas; ARect: TRect;
  46       State: TOwnerDrawState; TopLevel: Boolean); override;
  47     procedure DoDrawText(ACanvas: TCanvas; const ACaption: WideString;
  48       var Rect: TRect; Selected: Boolean; Flags: Integer);
  49     procedure MeasureItem(ACanvas: TCanvas; var Width, Height: Integer); override;
  50   public
  51     procedure InitiateAction; override;
  52     procedure Loaded; override;
  53     function Find(ACaption: WideString): TMenuItem{TNT-ALLOW TMenuItem};
  54   published
  55     property Caption: WideString read GetCaption write SetCaption stored IsCaptionStored;
  56     property Hint: WideString read GetHint write SetHint stored IsHintStored;
  57   end;
  58
  59 {TNT-WARN TMainMenu}
  60   TTntMainMenu = class(TMainMenu{TNT-ALLOW TMainMenu})
  61   protected
  62     procedure DoChange(Source: TMenuItem{TNT-ALLOW TMenuItem}; Rebuild: Boolean); override;
  63   public
  64     {$IFDEF COMPILER_9_UP}
  65     function CreateMenuItem: TMenuItem{TNT-ALLOW TMenuItem}; override;
  66     {$ENDIF}
  67   end;
  68
  69 {TNT-WARN TPopupMenu}
  70   TTntPopupMenu = class(TPopupMenu{TNT-ALLOW TPopupMenu})
  71   protected
  72     procedure DoChange(Source: TMenuItem{TNT-ALLOW TMenuItem}; Rebuild: Boolean); override;
  73   public
  74     constructor Create(AOwner: TComponent); override;
  75     {$IFDEF COMPILER_9_UP}
  76     function CreateMenuItem: TMenuItem{TNT-ALLOW TMenuItem}; override;
  77     {$ENDIF}
  78     destructor Destroy; override;
  79     procedure Popup(X, Y: Integer); override;
  80   end;
  81
  82 {TNT-WARN NewSubMenu}
  83 function WideNewSubMenu(const ACaption: WideString; hCtx: THelpContext;
  84   const AName: TComponentName; const Items: array of TTntMenuItem;
  85     AEnabled: Boolean): TTntMenuItem;
  86 {TNT-WARN NewItem}
  87 function WideNewItem(const ACaption: WideString; AShortCut: TShortCut;
  88   AChecked, AEnabled: Boolean; AOnClick: TNotifyEvent; hCtx: THelpContext;
  89     const AName: TComponentName): TTntMenuItem;
  90
  91 function MessageToShortCut(Msg: TWMKeyDown): TShortCut;
  92
  93 {TNT-WARN ShortCutToText}
  94 function WideShortCutToText(WordShortCut: Word): WideString;
  95 {TNT-WARN TextToShortCut}
  96 function WideTextToShortCut(Text: WideString): TShortCut;
  97 {TNT-WARN GetHotKey}
  98 function WideGetHotkey(const Text: WideString): WideString;
  99 {TNT-WARN StripHotkey}
 100 function WideStripHotkey(const Text: WideString): WideString;
 101 {TNT-WARN AnsiSameCaption}
 102 function WideSameCaption(const Text1, Text2: WideString): Boolean;
 103
 104 function WideGetMenuItemCaption(MenuItem: TMenuItem{TNT-ALLOW TMenuItem}): WideString;
 105 function WideGetMenuItemHint(MenuItem: TMenuItem{TNT-ALLOW TMenuItem}): WideString;
 106
 107 procedure NoOwnerDrawTopLevelItems(Menu: TMainMenu{TNT-ALLOW TMainMenu});
 108
 109 procedure FixMenuBiDiProblem(Menu: TMenu);
 110
 111 function MenuItemHasBitmap(MenuItem: TMenuItem{TNT-ALLOW TMenuItem}): Boolean;
 112
 113 type
 114   TTntPopupList = class(TPopupList)
 115   private
 116     SavedPopupList: TPopupList;
 117   protected
 118     procedure WndProc(var Message: TMessage); override;
 119   end;
 120
 121 var
 122   TntPopupList: TTntPopupList;
 123
 124 implementation
 125
 126 uses
 127   Forms, SysUtils, Consts, ActnList, ImgList, TntControls, TntGraphics,
 128   TntActnList, TntClasses, TntForms, TntSysUtils, TntWindows;
 129
 130 function WideNewSubMenu(const ACaption: WideString; hCtx: THelpContext;
 131   const AName: TComponentName; const Items: array of TTntMenuItem;
 132     AEnabled: Boolean): TTntMenuItem;
 133 var
 134   I: Integer;
 135 begin
 136   Result := TTntMenuItem.Create(nil);
 137   for I := Low(Items) to High(Items) do
 138     Result.Add(Items[I]);
 139   Result.Caption := ACaption;
 140   Result.HelpContext := hCtx;
 141   Result.Name := AName;
 142   Result.Enabled := AEnabled;
 143 end;
 144
 145 function WideNewItem(const ACaption: WideString; AShortCut: TShortCut;
 146   AChecked, AEnabled: Boolean; AOnClick: TNotifyEvent; hCtx: THelpContext;
 147     const AName: TComponentName): TTntMenuItem;
 148 begin
 149   Result := TTntMenuItem.Create(nil);
 150   with Result do
 151   begin
 152     Caption := ACaption;
 153     ShortCut := AShortCut;
 154     OnClick := AOnClick;
 155     HelpContext := hCtx;
 156     Checked := AChecked;
 157     Enabled := AEnabled;
 158     Name := AName;
 159   end;
 160 end;
 161
 162 function MessageToShortCut(Msg: TWMKeyDown): TShortCut;
 163 var
 164   ShiftState: TShiftState;
 165 begin
 166   ShiftState := Forms.KeyDataToShiftState(TWMKeyDown(Msg).KeyData);
 167   Result := Menus.ShortCut(TWMKeyDown(Msg).CharCode, ShiftState);
 168 end;
 169
 170 function WideGetSpecialName(WordShortCut: Word): WideString;
 171 var
 172   ScanCode: Integer;
 173   KeyName: array[0..255] of WideChar;
 174 begin
 175   Assert(Win32PlatformIsUnicode);
 176   Result := '';
 177   ScanCode := MapVirtualKeyW(WordRec(WordShortCut).Lo, 0) shl 16;
 178   if ScanCode <> 0 then
 179   begin
 180     GetKeyNameTextW(ScanCode, KeyName, SizeOf(KeyName));
 181     Result := KeyName;
 182   end;
 183 end;
 184
 185 function WideGetKeyboardChar(Key: Word): WideChar;
 186 var
 187   LatinNumChar: WideChar;
 188 begin
 189   Assert(Win32PlatformIsUnicode);
 190   Result := WideChar(MapVirtualKeyW(Key, 2));
 191   if (Key in [$30..$39]) then
 192   begin
 193     // Check to see if "0" - "9" can be used if all that differs is shift state
 194     LatinNumChar := WideChar(Key - $30 + Ord('0'));
 195     if (Result <> LatinNumChar)
 196     and (Byte(Key) = WordRec(VkKeyScanW(LatinNumChar)).Lo) then  // .Hi would be the shift state
 197       Result := LatinNumChar;
 198   end;
 199 end;
 200
 201 function WideShortCutToText(WordShortCut: Word): WideString;
 202 var
 203   Name: WideString;
 204 begin
 205   if (not Win32PlatformIsUnicode)
 206   or (WordRec(WordShortCut).Lo in [$08..$09 {BKSP, TAB}, $0D {ENTER}, $1B {ESC}, $20..$28 {Misc Nav},
 207                                $2D..$2E {INS, DEL}, $70..$87 {F1 - F24}])
 208   then
 209     Result := ShortCutToText{TNT-ALLOW ShortCutToText}(WordShortCut)
 210   else begin
 211     case WordRec(WordShortCut).Lo of
 212       $30..$39: Name := WideGetKeyboardChar(WordRec(WordShortCut).Lo); {1-9,0}
 213       $41..$5A: Name := WideGetKeyboardChar(WordRec(WordShortCut).Lo); {A-Z}
 214       $60..$69: Name := WideGetKeyboardChar(WordRec(WordShortCut).Lo); {numpad 1-9,0}
 215     else
 216       Name := WideGetSpecialName(WordShortCut);
 217     end;
 218     if Name <> '' then
 219     begin
 220       Result := '';
 221       if WordShortCut and scShift <> 0 then Result := Result + SmkcShift;
 222       if WordShortCut and scCtrl <> 0 then Result := Result + SmkcCtrl;
 223       if WordShortCut and scAlt <> 0 then Result := Result + SmkcAlt;
 224       Result := Result + Name;
 225     end
 226     else Result := '';
 227   end;
 228 end;
 229
 230 { This function is *very* slow.  Use sparingly.  Return 0 if no VK code was
 231   found for the text }
 232
 233 function WideTextToShortCut(Text: WideString): TShortCut;
 234
 235   { If the front of Text is equal to Front then remove the matching piece
 236     from Text and return True, otherwise return False }
 237
 238   function CompareFront(var Text: WideString; const Front: WideString): Boolean;
 239   begin
 240     Result := (Pos(Front, Text) = 1);
 241     if Result then
 242       Delete(Text, 1, Length(Front));
 243   end;
 244
 245 var
 246   Key: TShortCut;
 247   Shift: TShortCut;
 248 begin
 249   Result := 0;
 250   Shift := 0;
 251   while True do
 252   begin
 253     if      CompareFront(Text, SmkcShift) then Shift := Shift or scShift
 254     else if CompareFront(Text, '^')       then Shift := Shift or scCtrl
 255     else if CompareFront(Text, SmkcCtrl)  then Shift := Shift or scCtrl
 256     else if CompareFront(Text, SmkcAlt)   then Shift := Shift or scAlt
 257     else Break;
 258   end;
 259   if Text = '' then Exit;
 260   for Key := $08 to $255 do { Copy range from table in ShortCutToText }
 261     if WideSameText(Text, WideShortCutToText(Key)) then
 262     begin
 263       Result := Key or Shift;
 264       Exit;
 265     end;
 266 end;
 267
 268 function WideGetHotkeyPos(const Text: WideString): Integer;
 269 var
 270   I, L: Integer;
 271 begin
 272   Result := 0;
 273   I := 1;
 274   L := Length(Text);
 275   while I <= L do
 276   begin
 277     if (Text[I] = cHotkeyPrefix) and (L - I >= 1) then
 278     begin
 279       Inc(I);
 280       if Text[I] <> cHotkeyPrefix then
 281         Result := I; // this might not be the last
 282     end;
 283     Inc(I);
 284   end;
 285 end;
 286
 287 function WideGetHotkey(const Text: WideString): WideString;
 288 var
 289   I: Integer;
 290 begin
 291   I := WideGetHotkeyPos(Text);
 292   if I = 0 then
 293     Result := ''
 294   else
 295     Result := Text[I];
 296 end;
 297
 298 function WideStripHotkey(const Text: WideString): WideString;
 299 var
 300   I: Integer;
 301 begin
 302   Result := Text;
 303   I := 1;
 304   while I <= Length(Result) do
 305   begin
 306     if Result[I] = cHotkeyPrefix then
 307       if SysLocale.FarEast
 308       and ((I > 1) and (Length(Result) - I >= 2)
 309       and (Result[I - 1] = '(') and (Result[I + 2] = ')')) then begin
 310         Delete(Result, I - 1, 4);
 311         Dec(I, 2);
 312       end else
 313         Delete(Result, I, 1);
 314     Inc(I);
 315   end;
 316 end;
 317
 318 function WideSameCaption(const Text1, Text2: WideString): Boolean;
 319 begin
 320   Result := WideSameText(WideStripHotkey(Text1), WideStripHotkey(Text2));
 321 end;
 322
 323 function WideSameCaptionStr(const Text1, Text2: WideString): Boolean;
 324 begin
 325   Result := WideSameStr(WideStripHotkey(Text1), WideStripHotkey(Text2));
 326 end;
 327
 328 function WideGetMenuItemCaption(MenuItem: TMenuItem{TNT-ALLOW TMenuItem}): WideString;
 329 begin
 330   if MenuItem is TTntMenuItem then
 331     Result := TTntMenuItem(MenuItem).Caption
 332   else
 333     Result := MenuItem.Caption;
 334 end;
 335
 336 function WideGetMenuItemHint(MenuItem: TMenuItem{TNT-ALLOW TMenuItem}): WideString;
 337 begin
 338   if MenuItem is TTntMenuItem then
 339     Result := TTntMenuItem(MenuItem).Hint
 340   else
 341     Result := MenuItem.Hint;
 342 end;
 343
 344 procedure NoOwnerDrawTopLevelItems(Menu: TMainMenu{TNT-ALLOW TMainMenu});
 345 {If top-level items are created as owner-drawn, they will not appear as raised
 346 buttons when the mouse hovers over them. The VCL will often create top-level
 347 items as owner-drawn even when they don't need to be (owner-drawn state can be
 348 set on an item-by-item basis). This routine turns off the owner-drawn flag for
 349 top-level items if it appears unnecessary}
 350
 351   function ItemHasValidImage(Item: TMenuItem{TNT-ALLOW TMenuItem}): boolean;
 352   var
 353     Images: TCustomImageList;
 354   begin
 355     Assert(Item <> nil, 'TNT Internal Error: ItemHasValidImage: item = nil');
 356     Images := Item.GetImageList;
 357     Result := (Assigned(Images) and (Item.ImageIndex >= 0) and (Item.ImageIndex < Images.Count))
 358            or (MenuItemHasBitmap(Item) and (not Item.Bitmap.Empty))
 359   end;
 360
 361 var
 362   HM: HMenu;
 363   i: integer;
 364   Info: TMenuItemInfoA;
 365   Item: TMenuItem{TNT-ALLOW TMenuItem};
 366   Win98Plus: boolean;
 367 begin
 368   if Assigned(Menu) then begin
 369     Win98Plus:= (Win32MajorVersion > 4)
 370       or((Win32MajorVersion = 4) and (Win32MinorVersion > 0));
 371     if not Win98Plus then
 372       Exit; {exit if Windows 95 or NT 4.0}
 373     HM:= Menu.Handle;
 374     Info.cbSize:= sizeof(Info);
 375     for i := 0 to GetMenuItemCount(HM) - 1 do begin
 376       Info.fMask:= MIIM_FTYPE or MIIM_ID;
 377       if not GetMenuItemInfo(HM, i, true, Info) then
 378         Break;
 379       if Info.fType and MFT_OWNERDRAW <> 0 then begin
 380         Item:= Menu.FindItem(Info.wID, fkCommand);
 381         if not Assigned(Item) then
 382           continue;
 383         if Assigned(Item.OnDrawItem)
 384         or Assigned(Item.OnAdvancedDrawItem)
 385         or ItemHasValidImage(Item) then
 386           Continue;
 387         Info.fMask:= MIIM_FTYPE or MIIM_STRING;
 388         Info.fType:= (Info.fType and not MFT_OWNERDRAW) or MFT_STRING;
 389         if Win32PlatformIsUnicode and (Item is TTntMenuItem) then begin
 390           // Unicode
 391           TMenuItemInfoW(Info).dwTypeData:= PWideChar(TTntMenuItem(Item).Caption);
 392           SetMenuItemInfoW(HM, i, true, TMenuItemInfoW(Info));
 393         end else begin
 394           // Ansi
 395           Info.dwTypeData:= PAnsiChar(Item.Caption);
 396           SetMenuItemInfoA(HM, i, true, Info);
 397         end;
 398       end;
 399     end;
 400   end;
 401 end;
 402
 403 { TTntMenuItem's utility procs }
 404
 405 procedure SyncHotKeyPosition(const Source: WideString; var Dest: WideString);
 406 var
 407   I: Integer;
 408   FarEastHotString: WideString;
 409 begin
 410   if (AnsiString(Source) <> AnsiString(Dest))
 411   and WideSameCaptionStr(AnsiString(Source), AnsiString(Dest)) then begin
 412     // when reduced to ansi, the only difference is hot key positions
 413     Dest := WideStripHotkey(Dest);
 414     I := 1;
 415     while I <= Length(Source) do
 416     begin
 417       if Source[I] = cHotkeyPrefix then begin
 418         if SysLocale.FarEast
 419         and ((I > 1) and (Length(Source) - I >= 2)
 420         and (Source[I - 1] = '(') and (Source[I + 2] = ')')) then begin
 421           FarEastHotString := Copy(Source, I - 1, 4);
 422           Dec(I);
 423           Insert(FarEastHotString, Dest, I);
 424           Inc(I, 3);
 425         end else begin
 426           Insert(cHotkeyPrefix, Dest, I);
 427           Inc(I);
 428         end;
 429       end;
 430       Inc(I);
 431     end;
 432     // test work
 433     if AnsiString(Source) <> AnsiString(Dest) then
 434       raise ETntInternalError.CreateFmt('Internal Error: SyncHotKeyPosition Failed ("%s" <> "%s").',
 435         [AnsiString(Source), AnsiString(Dest)]);
 436   end;
 437 end;
 438
 439 procedure UpdateMenuItems(Items: TMenuItem{TNT-ALLOW TMenuItem}; ParentMenu: TMenu);
 440 var
 441   i: integer;
 442 begin
 443   if (Items.ComponentState * [csReading, csDestroying] = []) then begin
 444     for i := Items.Count - 1 downto 0 do
 445       UpdateMenuItems(Items[i], ParentMenu);
 446     if Items is TTntMenuItem then
 447       TTntMenuItem(Items).UpdateMenuString(ParentMenu);
 448   end;
 449 end;
 450
 451 procedure FixMenuBiDiProblem(Menu: TMenu);
 452 var
 453   i: integer;
 454 begin
 455   // TMenu sometimes sets bidi on first visible item which can convert caption to ansi
 456   if (SysLocale.MiddleEast)
 457   and (Menu <> nil)
 458   and (Menu.Items.Count > 0) then
 459   begin
 460     for i := 0 to Menu.Items.Count - 1 do begin
 461       if Menu.Items[i].Visible then begin
 462         if (Menu.Items[i] is TTntMenuItem) then
 463           (Menu.Items[i] as TTntMenuItem).UpdateMenuString(Menu);
 464         break; // found first visible menu item!
 465       end;
 466     end;
 467   end;
 468 end;
 469
 470
 471 {$IFDEF COMPILER_6} // verified against VCL source in Delphi 6 and BCB 6
 472 type
 473   THackMenuItem = class(TComponent)
 474   protected
 475     FxxxxCaption: Ansistring;
 476     FxxxxHandle: HMENU;
 477     FxxxxChecked: Boolean;
 478     FxxxxEnabled: Boolean;
 479     FxxxxDefault: Boolean;
 480     FxxxxAutoHotkeys: TMenuItemAutoFlag;
 481     FxxxxAutoLineReduction: TMenuItemAutoFlag;
 482     FxxxxRadioItem: Boolean;
 483     FxxxxVisible: Boolean;
 484     FxxxxGroupIndex: Byte;
 485     FxxxxImageIndex: TImageIndex;
 486     FxxxxActionLink: TMenuActionLink{TNT-ALLOW TMenuActionLink};
 487     FxxxxBreak: TMenuBreak;
 488     FBitmap: TBitmap;
 489     FxxxxCommand: Word;
 490     FxxxxHelpContext: THelpContext;
 491     FxxxxHint: AnsiString;
 492     FxxxxItems: TList;
 493     FxxxxShortCut: TShortCut;
 494     FxxxxParent: TMenuItem{TNT-ALLOW TMenuItem};
 495     FMerged: TMenuItem{TNT-ALLOW TMenuItem};
 496     FMergedWith: TMenuItem{TNT-ALLOW TMenuItem};
 497   end;
 498 {$ENDIF}
 499 {$IFDEF DELPHI_7} // verified against VCL source in Delphi 7
 500 type
 501   THackMenuItem = class(TComponent)
 502   protected
 503     FxxxxCaption: AnsiString;
 504     FxxxxHandle: HMENU;
 505     FxxxxChecked: Boolean;
 506     FxxxxEnabled: Boolean;
 507     FxxxxDefault: Boolean;
 508     FxxxxAutoHotkeys: TMenuItemAutoFlag;
 509     FxxxxAutoLineReduction: TMenuItemAutoFlag;
 510     FxxxxRadioItem: Boolean;
 511     FxxxxVisible: Boolean;
 512     FxxxxGroupIndex: Byte;
 513     FxxxxImageIndex: TImageIndex;
 514     FxxxxActionLink: TMenuActionLink{TNT-ALLOW TMenuActionLink};
 515     FxxxxBreak: TMenuBreak;
 516     FBitmap: TBitmap;
 517     FxxxxCommand: Word;
 518     FxxxxHelpContext: THelpContext;
 519     FxxxxHint: AnsiString;
 520     FxxxxItems: TList;
 521     FxxxxShortCut: TShortCut;
 522     FxxxxParent: TMenuItem{TNT-ALLOW TMenuItem};
 523     FMerged: TMenuItem{TNT-ALLOW TMenuItem};
 524     FMergedWith: TMenuItem{TNT-ALLOW TMenuItem};
 525   end;
 526 {$ENDIF}
 527 {$IFDEF DELPHI_9} // verified against VCL source in Delphi 9
 528 type
 529   THackMenuItem = class(TComponent)
 530   protected
 531     FxxxxCaption: AnsiString;
 532     FxxxxHandle: HMENU;
 533     FxxxxChecked: Boolean;
 534     FxxxxEnabled: Boolean;
 535     FxxxxDefault: Boolean;
 536     FxxxxAutoHotkeys: TMenuItemAutoFlag;
 537     FxxxxAutoLineReduction: TMenuItemAutoFlag;
 538     FxxxxRadioItem: Boolean;
 539     FxxxxVisible: Boolean;
 540     FxxxxGroupIndex: Byte;
 541     FxxxxImageIndex: TImageIndex;
 542     FxxxxActionLink: TMenuActionLink{TNT-ALLOW TMenuActionLink};
 543     FxxxxBreak: TMenuBreak;
 544     FBitmap: TBitmap;
 545     FxxxxCommand: Word;
 546     FxxxxHelpContext: THelpContext;
 547     FxxxxHint: AnsiString;
 548     FxxxxItems: TList;
 549     FxxxxShortCut: TShortCut;
 550     FxxxxParent: TMenuItem{TNT-ALLOW TMenuItem};
 551     FMerged: TMenuItem{TNT-ALLOW TMenuItem};
 552     FMergedWith: TMenuItem{TNT-ALLOW TMenuItem};
 553   end;
 554 {$ENDIF}
 555 {$IFDEF DELPHI_10} // verified against VCL source in Delphi 10
 556 type
 557   THackMenuItem = class(TComponent)
 558   protected
 559     FxxxxCaption: AnsiString;
 560     FxxxxHandle: HMENU;
 561     FxxxxChecked: Boolean;
 562     FxxxxEnabled: Boolean;
 563     FxxxxDefault: Boolean;
 564     FxxxxAutoHotkeys: TMenuItemAutoFlag;
 565     FxxxxAutoLineReduction: TMenuItemAutoFlag;
 566     FxxxxRadioItem: Boolean;
 567     FxxxxVisible: Boolean;
 568     FxxxxGroupIndex: Byte;
 569     FxxxxImageIndex: TImageIndex;
 570     FxxxxActionLink: TMenuActionLink{TNT-ALLOW TMenuActionLink};
 571     FxxxxBreak: TMenuBreak;
 572     FBitmap: TBitmap;
 573     FxxxxCommand: Word;
 574     FxxxxHelpContext: THelpContext;
 575     FxxxxHint: AnsiString;
 576     FxxxxItems: TList;
 577     FxxxxShortCut: TShortCut;
 578     FxxxxParent: TMenuItem{TNT-ALLOW TMenuItem};
 579     FMerged: TMenuItem{TNT-ALLOW TMenuItem};
 580     FMergedWith: TMenuItem{TNT-ALLOW TMenuItem};
 581   end;
 582 {$ENDIF}
 583
 584 function MenuItemHasBitmap(MenuItem: TMenuItem{TNT-ALLOW TMenuItem}): Boolean;
 585 begin
 586   Result := Assigned(THackMenuItem(MenuItem).FBitmap);
 587 end;
 588
 589 { TTntMenuItem }
 590
 591 procedure TTntMenuItem.DefineProperties(Filer: TFiler);
 592 begin
 593   inherited;
 594   TntPersistent_AfterInherited_DefineProperties(Filer, Self);
 595 end;
 596
 597 type TAccessActionlink = class(TActionLink);
 598
 599 procedure TTntMenuItem.InitiateAction;
 600 begin
 601   if GetKeyboardLayout(0) <> FKeyboardLayout then
 602     MenuChanged(False);
 603   inherited;
 604 end;
 605
 606 function TTntMenuItem.IsCaptionStored: Boolean;
 607 begin
 608   Result := (ActionLink = nil) or (not TAccessActionlink(ActionLink).IsCaptionLinked);
 609 end;
 610
 611 procedure TTntMenuItem.SetInheritedCaption(const Value: AnsiString);
 612 begin
 613   inherited Caption := Value;
 614 end;
 615
 616 function TTntMenuItem.GetCaption: WideString;
 617 begin
 618   if (AnsiString(FCaption) <> inherited Caption)
 619   and WideSameCaptionStr(AnsiString(FCaption), inherited Caption) then
 620   begin
 621     // only difference is hotkey position, update caption with new hotkey position
 622     SyncHotKeyPosition(inherited Caption, FCaption);
 623   end;
 624   Result := GetSyncedWideString(FCaption, (inherited Caption));
 625 end;
 626
 627 procedure TTntMenuItem.SetCaption(const Value: WideString);
 628 begin
 629   GetCaption; // auto adjust for hot key changes
 630   SetSyncedWideString(Value, FCaption, (inherited Caption), SetInheritedCaption);
 631 end;
 632
 633 function TTntMenuItem.GetHint: WideString;
 634 begin
 635   Result := GetSyncedWideString(FHint, inherited Hint);
 636 end;
 637
 638 procedure TTntMenuItem.SetInheritedHint(const Value: AnsiString);
 639 begin
 640   inherited Hint := Value;
 641 end;
 642
 643 procedure TTntMenuItem.SetHint(const Value: WideString);
 644 begin
 645   SetSyncedWideString(Value, FHint, inherited Hint, SetInheritedHint);
 646 end;
 647
 648 function TTntMenuItem.IsHintStored: Boolean;
 649 begin
 650   Result := (ActionLink = nil) or not TAccessActionlink(ActionLink).IsHintLinked;
 651 end;
 652
 653 procedure TTntMenuItem.Loaded;
 654 begin
 655   inherited;
 656   UpdateMenuString(GetParentMenu);
 657 end;
 658
 659 procedure TTntMenuItem.MenuChanged(Rebuild: Boolean);
 660 begin
 661   if (not FIgnoreMenuChanged) then begin
 662     inherited;
 663     UpdateMenuItems(Self, GetParentMenu);
 664     FixMenuBiDiProblem(GetParentMenu);
 665   end;
 666 end;
 667
 668 procedure TTntMenuItem.UpdateMenuString(ParentMenu: TMenu);
 669 var
 670   ParentHandle: THandle;
 671
 672   function NativeMenuTypeIsString: Boolean;
 673   var
 674     MenuItemInfo: TMenuItemInfoW;
 675     Buffer: array[0..79] of WideChar;
 676   begin
 677     MenuItemInfo.cbSize := 44; // Required for Windows NT 4.0
 678     MenuItemInfo.fMask := MIIM_TYPE;
 679     MenuItemInfo.dwTypeData := Buffer; // ??
 680     MenuItemInfo.cch := Length(Buffer); // ??
 681     Result := GetMenuItemInfoW(ParentHandle, Command, False, MenuItemInfo)
 682          and ((MenuItemInfo.fType and (MFT_BITMAP or MFT_SEPARATOR or MFT_OWNERDRAW)) = 0)
 683   end;
 684
 685   function NativeMenuString: WideString;
 686   var
 687     Len: Integer;
 688   begin
 689     Assert(Win32PlatformIsUnicode);
 690     Len := GetMenuStringW(ParentHandle, Command, nil, 0, MF_BYCOMMAND);
 691     if Len = 0 then
 692       Result := ''
 693     else begin
 694       SetLength(Result, Len + 1);
 695       Len := GetMenuStringW(ParentHandle, Command, PWideChar(Result), Len + 1, MF_BYCOMMAND);
 696       SetLength(Result, Len);
 697     end;
 698   end;
 699
 700   procedure SetMenuString(const Value: WideString);
 701   var
 702     MenuItemInfo: TMenuItemInfoW;
 703     Buffer: array[0..79] of WideChar;
 704   begin
 705     MenuItemInfo.cbSize := 44; // Required for Windows NT 4.0
 706     MenuItemInfo.fMask := MIIM_TYPE;
 707     MenuItemInfo.dwTypeData := Buffer; // ??
 708     MenuItemInfo.cch := Length(Buffer); // ??
 709     if GetMenuItemInfoW(ParentHandle, Command, False, MenuItemInfo)
 710     and ((MenuItemInfo.fType and (MFT_BITMAP or MFT_SEPARATOR or MFT_OWNERDRAW)) = 0) then
 711     begin
 712       MenuItemInfo.dwTypeData := PWideChar(Value);
 713       MenuItemInfo.cch := Length(Value);
 714       Win32Check(SetMenuItemInfoW(ParentHandle, Command, False, MenuItemInfo));
 715     end;
 716   end;
 717
 718   function SameEvent(A, B: TMenuMeasureItemEvent): Boolean;
 719   begin
 720     Result := @A = @B;
 721   end;
 722
 723 var
 724   MenuCaption: WideString;
 725 begin
 726   FKeyboardLayout := GetKeyboardLayout(0);
 727   if Parent = nil then
 728     ParentHandle := 0
 729   else if (THackMenuItem(Self.Parent).FMergedWith <> nil) then
 730     ParentHandle := THackMenuItem(Self.Parent).FMergedWith.Handle
 731   else
 732     ParentHandle := Parent.Handle;
 733
 734   if (Win32PlatformIsUnicode)
 735   and (Parent <> nil) and (ParentMenu <> nil)
 736   and (ComponentState * [csReading, csDestroying] = [])
 737   and (Visible)
 738   and (NativeMenuTypeIsString) then begin
 739     MenuCaption := Caption;
 740     if (Count = 0)
 741     and ((ShortCut <> scNone)
 742     and ((Parent = nil) or (Parent.Parent <> nil) or not (Parent.Owner is TMainMenu{TNT-ALLOW TMainMenu}))) then
 743       MenuCaption := MenuCaption + #9 + WideShortCutToText(ShortCut);
 744     if (NativeMenuString <> MenuCaption) then
 745     begin
 746       SetMenuString(MenuCaption);
 747       if  ((Parent = ParentMenu.Items) or (THackMenuItem(Self.Parent).FMergedWith <> nil))
 748       and (ParentMenu is TMainMenu{TNT-ALLOW TMainMenu})
 749       and (ParentMenu.WindowHandle <> 0) then
 750         DrawMenuBar(ParentMenu.WindowHandle) {top level menu bar items}
 751     end;
 752   end;
 753 end;
 754
 755 function TTntMenuItem.GetAlignmentDrawStyle: Word;
 756 const
 757   Alignments: array[TPopupAlignment] of Word = (DT_LEFT, DT_RIGHT, DT_CENTER);
 758 var
 759   ParentMenu: TMenu;
 760   Alignment: TPopupAlignment;
 761 begin
 762   ParentMenu := GetParentMenu;
 763   if ParentMenu is TMenu then
 764     Alignment := paLeft
 765   else if ParentMenu is TPopupMenu{TNT-ALLOW TPopupMenu} then
 766     Alignment := TPopupMenu{TNT-ALLOW TPopupMenu}(ParentMenu).Alignment
 767   else
 768     Alignment := paLeft;
 769   Result := Alignments[Alignment];
 770 end;
 771
 772 procedure TTntMenuItem.AdvancedDrawItem(ACanvas: TCanvas; ARect: TRect;
 773   State: TOwnerDrawState; TopLevel: Boolean);
 774
 775   procedure DrawMenuText(BiDi: Boolean);
 776   var
 777     ImageList: TCustomImageList;
 778     DrawImage, DrawGlyph: Boolean;
 779     GlyphRect, SaveRect: TRect;
 780     DrawStyle: Longint;
 781     Selected: Boolean;
 782     Win98Plus: Boolean;
 783     Win2K: Boolean;
 784   begin
 785     ImageList := GetImageList;
 786     Selected := odSelected in State;
 787     Win98Plus := (Win32MajorVersion > 4) or
 788       ((Win32MajorVersion = 4) and (Win32MinorVersion > 0));
 789     Win2K := (Win32MajorVersion > 4) and (Win32Platform = VER_PLATFORM_WIN32_NT);
 790     with ACanvas do
 791     begin
 792       GlyphRect.Left := ARect.Left + 1;
 793       DrawImage := (ImageList <> nil) and ((ImageIndex > -1) and
 794         (ImageIndex < ImageList.Count) or Checked and ((not MenuItemHasBitmap(Self)) or
 795         Bitmap.Empty));
 796       if DrawImage or MenuItemHasBitmap(Self) and not Bitmap.Empty then
 797       begin
 798         DrawGlyph := True;
 799         if DrawImage then
 800           GlyphRect.Right := GlyphRect.Left + ImageList.Width
 801         else begin
 802           { Need to add BitmapWidth/Height properties for TMenuItem if we're to
 803             support them.  Right now let's hardcode them to 16x16. }
 804           GlyphRect.Right := GlyphRect.Left + 16;
 805         end;
 806         { Draw background pattern brush if selected }
 807         if Checked then
 808         begin
 809           Inc(GlyphRect.Right);
 810           if not Selected then
 811             Brush.Bitmap := AllocPatternBitmap(clBtnFace, clBtnHighlight);
 812           Inc(GlyphRect.Left);
 813         end;
 814         if Checked then
 815           Dec(GlyphRect.Right);
 816       end else begin
 817         if (ImageList <> nil) and (not TopLevel) then
 818           GlyphRect.Right := GlyphRect.Left + ImageList.Width
 819         else
 820           GlyphRect.Right := GlyphRect.Left;
 821         DrawGlyph := False;
 822       end;
 823       if BiDi then begin
 824         SaveRect := GlyphRect;
 825         GlyphRect.Left := ARect.Right - (SaveRect.Right - ARect.Left);
 826         GlyphRect.Right := ARect.Right - (SaveRect.Left - ARect.Left);
 827       end;
 828       with GlyphRect do begin
 829         Dec(Left);
 830         Inc(Right, 2);
 831       end;
 832       if Selected then begin
 833         if DrawGlyph then begin
 834           if BiDi then
 835             ARect.Right := GlyphRect.Left - 1
 836           else
 837             ARect.Left := GlyphRect.Right + 1;
 838         end;
 839         if not (Win98Plus and TopLevel) then
 840           Brush.Color := clHighlight;
 841       end;
 842       if TopLevel and Win98Plus and (not Selected)
 843       {$IFDEF COMPILER_7_UP}
 844       and (not Win32PlatformIsXP)
 845       {$ENDIF}
 846       then
 847         OffsetRect(ARect, 0, -1);
 848       if not (Selected and DrawGlyph) then begin
 849         if BiDi then
 850           ARect.Right := GlyphRect.Left - 1
 851         else
 852           ARect.Left := GlyphRect.Right + 1;
 853       end;
 854       Inc(ARect.Left, 2);
 855       Dec(ARect.Right, 1);
 856       DrawStyle := DT_EXPANDTABS or DT_SINGLELINE or GetAlignmentDrawStyle;
 857       if Win2K and (odNoAccel in State) then
 858         DrawStyle := DrawStyle or DT_HIDEPREFIX;
 859       { Calculate vertical layout }
 860       SaveRect := ARect;
 861       if odDefault in State then
 862         Font.Style := [fsBold];
 863       DoDrawText(ACanvas, Caption, ARect, Selected, DrawStyle or DT_CALCRECT or DT_NOCLIP);
 864       if BiDi then begin
 865         { the DT_CALCRECT does not take into account alignment }
 866         ARect.Left := SaveRect.Left;
 867         ARect.Right := SaveRect.Right;
 868       end;
 869       OffsetRect(ARect, 0, ((SaveRect.Bottom - SaveRect.Top) - (ARect.Bottom - ARect.Top)) div 2);
 870       if TopLevel and Selected and Win98Plus
 871       {$IFDEF COMPILER_7_UP}
 872       and (not Win32PlatformIsXP)
 873       {$ENDIF}
 874       then
 875         OffsetRect(ARect, 1, 0);
 876       DoDrawText(ACanvas, Caption, ARect, Selected, DrawStyle);
 877       if (ShortCut <> scNone) and not TopLevel then
 878       begin
 879         if BiDi then begin
 880           ARect.Left := 10;
 881           ARect.Right := ARect.Left + WideCanvasTextWidth(ACanvas, WideShortCutToText(ShortCut));
 882         end else begin
 883           ARect.Left := ARect.Right;
 884           ARect.Right := SaveRect.Right - 10;
 885         end;
 886         DoDrawText(ACanvas, WideShortCutToText(ShortCut), ARect, Selected, DT_RIGHT);
 887       end;
 888     end;
 889   end;
 890
 891 var
 892   ParentMenu: TMenu;
 893   SaveCaption: WideString;
 894   SaveShortCut: TShortCut;
 895 begin
 896   ParentMenu := GetParentMenu;
 897   if (not Win32PlatformIsUnicode)
 898   or (Self.IsLine)
 899   or (     (ParentMenu <> nil) and (ParentMenu.OwnerDraw or (GetImageList <> nil))
 900        and (Assigned(OnAdvancedDrawItem) or Assigned(OnDrawItem))    ) then
 901     inherited
 902   else begin
 903     SaveCaption := Caption;
 904     SaveShortCut := ShortCut;
 905     try
 906       FIgnoreMenuChanged := True;
 907       try
 908         Caption := '';
 909         ShortCut := scNone;
 910       finally
 911         FIgnoreMenuChanged := False;
 912       end;
 913       inherited;
 914     finally
 915       FIgnoreMenuChanged := True;
 916       try
 917         Caption := SaveCaption;
 918         ShortCut := SaveShortcut;
 919       finally
 920         FIgnoreMenuChanged := False;
 921       end;
 922     end;
 923     DrawMenuText((ParentMenu <> nil) and (ParentMenu.IsRightToLeft))
 924   end;
 925 end;
 926
 927 procedure TTntMenuItem.DoDrawText(ACanvas: TCanvas; const ACaption: WideString;
 928   var Rect: TRect; Selected: Boolean; Flags: Longint);
 929 var
 930   Text: WideString;
 931   ParentMenu: TMenu;
 932 begin
 933   if (not Win32PlatformIsUnicode)
 934   or (IsLine) then
 935     inherited DoDrawText(ACanvas, ACaption, Rect, Selected, Flags)
 936   else begin
 937     ParentMenu := GetParentMenu;
 938     if (ParentMenu <> nil) and (ParentMenu.IsRightToLeft) then
 939     begin
 940       if Flags and DT_LEFT = DT_LEFT then
 941         Flags := Flags and (not DT_LEFT) or DT_RIGHT
 942       else if Flags and DT_RIGHT = DT_RIGHT then
 943         Flags := Flags and (not DT_RIGHT) or DT_LEFT;
 944       Flags := Flags or DT_RTLREADING;
 945     end;
 946     Text := ACaption;
 947     if (Flags and DT_CALCRECT <> 0) and ((Text = '') or
 948       (Text[1] = cHotkeyPrefix) and (Text[2] = #0)) then Text := Text + ' ';
 949     with ACanvas do
 950     begin
 951       Brush.Style := bsClear;
 952       if Default then
 953         Font.Style := Font.Style + [fsBold];
 954       if not Enabled then
 955       begin
 956         if not Selected then
 957         begin
 958           OffsetRect(Rect, 1, 1);
 959           Font.Color := clBtnHighlight;
 960           Tnt_DrawTextW(Handle, PWideChar(Text), Length(Text), Rect, Flags);
 961           OffsetRect(Rect, -1, -1);
 962         end;
 963         if Selected and (ColorToRGB(clHighlight) = ColorToRGB(clBtnShadow)) then
 964           Font.Color := clBtnHighlight else
 965           Font.Color := clBtnShadow;
 966       end;
 967       Tnt_DrawTextW(Handle, PWideChar(Text), Length(Text), Rect, Flags);
 968     end;
 969   end;
 970 end;
 971
 972 function TTntMenuItem.MeasureItemTextWidth(ACanvas: TCanvas; const Text: WideString): Integer;
 973 var
 974   R: TRect;
 975 begin
 976   FillChar(R, SizeOf(R), 0);
 977   DoDrawText(ACanvas, Text, R, False,
 978     GetAlignmentDrawStyle or DT_EXPANDTABS or DT_SINGLELINE or DT_NOCLIP or DT_CALCRECT);
 979   Result := R.Right - R.Left;
 980 end;
 981
 982 procedure TTntMenuItem.MeasureItem(ACanvas: TCanvas; var Width, Height: Integer);
 983 var
 984   SaveMeasureItemEvent: TMenuMeasureItemEvent;
 985 begin
 986   if (not Win32PlatformIsUnicode)
 987   or (Self.IsLine) then
 988     inherited
 989   else begin
 990     SaveMeasureItemEvent := inherited OnMeasureItem;
 991     try
 992       inherited OnMeasureItem := nil;
 993       inherited;
 994       Inc(Width, MeasureItemTextWidth(ACanvas, Caption));
 995       Dec(Width, MeasureItemTextWidth(ACanvas, inherited Caption));
 996       if ShortCut <> scNone then begin
 997         Inc(Width, MeasureItemTextWidth(ACanvas, WideShortCutToText(ShortCut)));
 998         Dec(Width, MeasureItemTextWidth(ACanvas, ShortCutToText{TNT-ALLOW ShortCutToText}(ShortCut)));
 999       end;
1000     finally
1001       inherited OnMeasureItem := SaveMeasureItemEvent;
1002     end;
1003     if Assigned(OnMeasureItem) then OnMeasureItem(Self, ACanvas, Width, Height);
1004   end;
1005 end;
1006
1007 function TTntMenuItem.Find(ACaption: WideString): TMenuItem{TNT-ALLOW TMenuItem};
1008 var
1009   I: Integer;
1010 begin
1011   Result := nil;
1012   ACaption := WideStripHotkey(ACaption);
1013   for I := 0 to Count - 1 do
1014     if WideSameText(ACaption, WideStripHotkey(WideGetMenuItemCaption(Items[I]))) then
1015     begin
1016       Result := Items[I];
1017       System.Break;
1018     end;
1019 end;
1020
1021 function TTntMenuItem.GetActionLinkClass: TMenuActionLinkClass;
1022 begin
1023   Result := TTntMenuActionLink;
1024 end;
1025
1026 procedure TTntMenuItem.ActionChange(Sender: TObject; CheckDefaults: Boolean);
1027 begin
1028   if (Sender is TCustomAction{TNT-ALLOW TCustomAction}) and Supports(Sender, ITntAction) then begin
1029     if not CheckDefaults or (Caption = '') then
1030       Caption := TntAction_GetCaption(TCustomAction{TNT-ALLOW TCustomAction}(Sender));
1031     if not CheckDefaults or (Hint = '') then
1032       Hint := TntAction_GetHint(TCustomAction{TNT-ALLOW TCustomAction}(Sender));
1033   end;
1034   inherited;
1035 end;
1036
1037 { TTntMainMenu }
1038
1039 {$IFDEF COMPILER_9_UP}
1040 function TTntMainMenu.CreateMenuItem: TMenuItem{TNT-ALLOW TMenuItem};
1041 begin
1042   Result := TTntMenuItem.Create(Self);
1043 end;
1044 {$ENDIF}
1045
1046 procedure TTntMainMenu.DoChange(Source: TMenuItem{TNT-ALLOW TMenuItem}; Rebuild: Boolean);
1047 begin
1048   inherited;
1049   UpdateMenuItems(Items, Self);
1050   if (THackMenuItem(Items).FMerged <> nil) then begin
1051     UpdateMenuItems(THackMenuItem(Items).FMerged, Self);
1052   end;
1053 end;
1054
1055 { TTntPopupMenu }
1056
1057 constructor TTntPopupMenu.Create(AOwner: TComponent);
1058 begin
1059   inherited;
1060   PopupList.Remove(Self);
1061   if TntPopupList <> nil then
1062     TntPopupList.Add(Self);
1063 end;
1064
1065 {$IFDEF COMPILER_9_UP}
1066 function TTntPopupMenu.CreateMenuItem: TMenuItem{TNT-ALLOW TMenuItem};
1067 begin
1068   Result := TTntMenuItem.Create(Self);
1069 end;
1070 {$ENDIF}
1071
1072 destructor TTntPopupMenu.Destroy;
1073 begin
1074   if TntPopupList <> nil then
1075     TntPopupList.Remove(Self);
1076   PopupList.Add(Self);
1077   inherited;
1078 end;
1079
1080 procedure TTntPopupMenu.DoChange(Source: TMenuItem{TNT-ALLOW TMenuItem}; Rebuild: Boolean);
1081 begin
1082   inherited;
1083   UpdateMenuItems(Items, Self);
1084 end;
1085
1086 procedure TTntPopupMenu.Popup(X, Y: Integer);
1087 begin
1088   Menus.PopupList := TntPopupList;
1089   try
1090     inherited;
1091   finally
1092     Menus.PopupList := TntPopupList.SavedPopupList;
1093   end;
1094 end;
1095
1096 { TTntPopupList }
1097
1098 procedure TTntPopupList.WndProc(var Message: TMessage);
1099 var
1100   I, Item: Integer;
1101   MenuItem: TMenuItem{TNT-ALLOW TMenuItem};
1102   FindKind: TFindItemKind;
1103 begin
1104   case Message.Msg of
1105     WM_ENTERMENULOOP:
1106       begin
1107         Menus.PopupList := SavedPopupList;
1108         for i := 0 to Count - 1 do
1109           FixMenuBiDiProblem(Items[i]);
1110       end;
1111     WM_MENUSELECT:
1112       with TWMMenuSelect(Message) do
1113       begin
1114         FindKind := fkCommand;
1115         if MenuFlag and MF_POPUP <> 0 then FindKind := fkHandle;
1116         for I := 0 to Count - 1 do
1117         begin
1118           if FindKind = fkHandle then
1119           begin
1120             if Menu <> 0 then
1121               Item := Integer(GetSubMenu(Menu, IDItem)) else
1122               Item := -1;
1123           end
1124           else
1125             Item := IDItem;
1126           MenuItem := TPopupMenu{TNT-ALLOW TPopupMenu}(Items[I]).FindItem(Item, FindKind);
1127           if MenuItem <> nil then
1128           begin
1129             TntApplication.Hint := WideGetLongHint(WideGetMenuItemHint(MenuItem));
1130             Exit;
1131           end;
1132         end;
1133         TntApplication.Hint := '';
1134       end;
1135   end;
1136   inherited;
1137 end;
1138
1139 initialization
1140   TntPopupList := TTntPopupList.Create;
1141   TntPopupList.SavedPopupList := Menus.PopupList;
1142
1143 finalization
1144   FreeAndNil(TntPopupList);
1145
1146 end.