tntmenus.pas

Make your Delphi application UNICODE enabled.

          Continue;
        Info.fMask:= MIIM_FTYPE or MIIM_STRING;
        Info.fType:= (Info.fType and not MFT_OWNERDRAW) or MFT_STRING;
        if Win32PlatformIsUnicode and (Item is TTntMenuItem) then begin
          // Unicode
          TMenuItemInfoW(Info).dwTypeData:= PWideChar(TTntMenuItem(Item).Caption);
          SetMenuItemInfoW(HM, i, true, TMenuItemInfoW(Info));
        end else begin
          // Ansi
          Info.dwTypeData:= PAnsiChar(Item.Caption);
          SetMenuItemInfoA(HM, i, true, Info);
        end;
      end;
    end;
  end;
end;

{ TTntMenuItem's utility procs }

procedure SyncHotKeyPosition(const Source: WideString; var Dest: WideString);
var
  I: Integer;
  FarEastHotString: WideString;
begin
  if (AnsiString(Source) <> AnsiString(Dest))
  and WideSameCaptionStr(AnsiString(Source), AnsiString(Dest)) then begin
    // when reduced to ansi, the only difference is hot key positions
    Dest := WideStripHotkey(Dest);
    I := 1;
    while I <= Length(Source) do
    begin
      if Source[I] = cHotkeyPrefix then begin
        if SysLocale.FarEast
        and ((I > 1) and (Length(Source) - I >= 2)
        and (Source[I - 1] = '(') and (Source[I + 2] = ')')) then begin
          FarEastHotString := Copy(Source, I - 1, 4);
          Dec(I);
          Insert(FarEastHotString, Dest, I);
          Inc(I, 3);
        end else begin
          Insert(cHotkeyPrefix, Dest, I);
          Inc(I);
        end;
      end;
      Inc(I);
    end;
    // test work
    if AnsiString(Source) <> AnsiString(Dest) then
      raise ETntInternalError.CreateFmt('Internal Error: SyncHotKeyPosition Failed ("%s" <> "%s").',
        [AnsiString(Source), AnsiString(Dest)]);
  end;
end;

procedure UpdateMenuItems(Items: TMenuItem{TNT-ALLOW TMenuItem}; ParentMenu: TMenu);
var
  i: integer;
begin
  if (Items.ComponentState * [csReading, csDestroying] = []) then begin
    for i := Items.Count - 1 downto 0 do
      UpdateMenuItems(Items[i], ParentMenu);
    if Items is TTntMenuItem then
      TTntMenuItem(Items).UpdateMenuString(ParentMenu);
  end;
end;

procedure FixMenuBiDiProblem(Menu: TMenu);
begin
  // TMenu sometimes sets bidi on item[0] which can convert caption to ansi
  if (SysLocale.MiddleEast) then begin
    if (Menu <> nil)
    and (Menu.Items.Count > 0)
    and (Menu.Items[0] is TTntMenuItem) then
    begin
      (Menu.Items[0] as TTntMenuItem).UpdateMenuString(Menu);
    end;
  end;
end;

{$IFDEF COMPILER_6} // verified against VCL source in Delphi 6 and BCB 6
type
  THackMenuItem = class(TComponent)
  protected
    FxxxxCaption: Ansistring;
    FxxxxHandle: HMENU;
    FxxxxChecked: Boolean;
    FxxxxEnabled: Boolean;
    FxxxxDefault: Boolean;
    FxxxxAutoHotkeys: TMenuItemAutoFlag;
    FxxxxAutoLineReduction: TMenuItemAutoFlag;
    FxxxxRadioItem: Boolean;
    FxxxxVisible: Boolean;
    FxxxxGroupIndex: Byte;
    FxxxxImageIndex: TImageIndex;
    FxxxxActionLink: TMenuActionLink{TNT-ALLOW TMenuActionLink};
    FxxxxBreak: TMenuBreak;
    FBitmap: TBitmap;
    FxxxxCommand: Word;
    FxxxxHelpContext: THelpContext;
    FxxxxHint: AnsiString;
    FxxxxItems: TList;
    FxxxxShortCut: TShortCut;
    FxxxxParent: TMenuItem{TNT-ALLOW TMenuItem};
    FMerged: TMenuItem{TNT-ALLOW TMenuItem};
    FMergedWith: TMenuItem{TNT-ALLOW TMenuItem};
  end;
{$ENDIF}
{$IFDEF DELPHI_7} // verified against VCL source in Delphi 7
type
  THackMenuItem = class(TComponent)
  protected
    FxxxxCaption: AnsiString;
    FxxxxHandle: HMENU;
    FxxxxChecked: Boolean;
    FxxxxEnabled: Boolean;
    FxxxxDefault: Boolean;
    FxxxxAutoHotkeys: TMenuItemAutoFlag;
    FxxxxAutoLineReduction: TMenuItemAutoFlag;
    FxxxxRadioItem: Boolean;
    FxxxxVisible: Boolean;
    FxxxxGroupIndex: Byte;
    FxxxxImageIndex: TImageIndex;
    FxxxxActionLink: TMenuActionLink{TNT-ALLOW TMenuActionLink};
    FxxxxBreak: TMenuBreak;
    FBitmap: TBitmap;
    FxxxxCommand: Word;
    FxxxxHelpContext: THelpContext;
    FxxxxHint: AnsiString;
    FxxxxItems: TList;
    FxxxxShortCut: TShortCut;
    FxxxxParent: TMenuItem{TNT-ALLOW TMenuItem};
    FMerged: TMenuItem{TNT-ALLOW TMenuItem};
    FMergedWith: TMenuItem{TNT-ALLOW TMenuItem};
  end;
{$ENDIF}
{$IFDEF DELPHI_9} // verified against VCL source in Delphi 9
type
  THackMenuItem = class(TComponent)
  protected
    FxxxxCaption: AnsiString;
    FxxxxHandle: HMENU;
    FxxxxChecked: Boolean;
    FxxxxEnabled: Boolean;
    FxxxxDefault: Boolean;
    FxxxxAutoHotkeys: TMenuItemAutoFlag;
    FxxxxAutoLineReduction: TMenuItemAutoFlag;
    FxxxxRadioItem: Boolean;
    FxxxxVisible: Boolean;
    FxxxxGroupIndex: Byte;
    FxxxxImageIndex: TImageIndex;
    FxxxxActionLink: TMenuActionLink{TNT-ALLOW TMenuActionLink};
    FxxxxBreak: TMenuBreak;
    FBitmap: TBitmap;
    FxxxxCommand: Word;
    FxxxxHelpContext: THelpContext;
    FxxxxHint: AnsiString;
    FxxxxItems: TList;
    FxxxxShortCut: TShortCut;
    FxxxxParent: TMenuItem{TNT-ALLOW TMenuItem};
    FMerged: TMenuItem{TNT-ALLOW TMenuItem};
    FMergedWith: TMenuItem{TNT-ALLOW TMenuItem};
  end;
{$ENDIF}
{$IFDEF DELPHI_10} // verified against VCL source in Delphi 10
type
  THackMenuItem = class(TComponent)
  protected
    FxxxxCaption: AnsiString;
    FxxxxHandle: HMENU;
    FxxxxChecked: Boolean;
    FxxxxEnabled: Boolean;
    FxxxxDefault: Boolean;
    FxxxxAutoHotkeys: TMenuItemAutoFlag;
    FxxxxAutoLineReduction: TMenuItemAutoFlag;
    FxxxxRadioItem: Boolean;
    FxxxxVisible: Boolean;
    FxxxxGroupIndex: Byte;
    FxxxxImageIndex: TImageIndex;
    FxxxxActionLink: TMenuActionLink{TNT-ALLOW TMenuActionLink};
    FxxxxBreak: TMenuBreak;
    FBitmap: TBitmap;
    FxxxxCommand: Word;
    FxxxxHelpContext: THelpContext;
    FxxxxHint: AnsiString;
    FxxxxItems: TList;
    FxxxxShortCut: TShortCut;
    FxxxxParent: TMenuItem{TNT-ALLOW TMenuItem};
    FMerged: TMenuItem{TNT-ALLOW TMenuItem};
    FMergedWith: TMenuItem{TNT-ALLOW TMenuItem};
  end;
{$ENDIF}

function MenuItemHasBitmap(MenuItem: TMenuItem{TNT-ALLOW TMenuItem}): Boolean;
begin
  Result := Assigned(THackMenuItem(MenuItem).FBitmap);
end;

{ TTntMenuItem }

procedure TTntMenuItem.DefineProperties(Filer: TFiler);
begin
  inherited;
  TntPersistent_AfterInherited_DefineProperties(Filer, Self);
end;

type TAccessActionlink = class(TActionLink);

function TTntMenuItem.IsCaptionStored: Boolean;
begin
  Result := (ActionLink = nil) or (not TAccessActionlink(ActionLink).IsCaptionLinked);
end;

procedure TTntMenuItem.SetInheritedCaption(const Value: AnsiString);
begin
  inherited Caption := Value;
end;

function TTntMenuItem.GetCaption: WideString;
begin
  if (AnsiString(FCaption) <> inherited Caption)
  and WideSameCaptionStr(AnsiString(FCaption), inherited Caption) then
  begin
    // only difference is hotkey position, update caption with new hotkey position
    SyncHotKeyPosition(inherited Caption, FCaption);
  end;
  Result := GetSyncedWideString(FCaption, (inherited Caption));
end;

procedure TTntMenuItem.SetCaption(const Value: WideString);
begin
  GetCaption; // auto adjust for hot key changes
  SetSyncedWideString(Value, FCaption, (inherited Caption), SetInheritedCaption);
end;

function TTntMenuItem.GetHint: WideString;
begin
  Result := GetSyncedWideString(FHint, inherited Hint);
end;

procedure TTntMenuItem.SetInheritedHint(const Value: AnsiString);
begin
  inherited Hint := Value;
end;

procedure TTntMenuItem.SetHint(const Value: WideString);
begin
  SetSyncedWideString(Value, FHint, inherited Hint, SetInheritedHint);
end;

function TTntMenuItem.IsHintStored: Boolean;
begin
  Result := (ActionLink = nil) or not TAccessActionlink(ActionLink).IsHintLinked;
end;

procedure TTntMenuItem.Loaded;
begin
  inherited;
  UpdateMenuString(GetParentMenu);
end;

procedure TTntMenuItem.MenuChanged(Rebuild: Boolean);
begin
  if (not FIgnoreMenuChanged) then begin
    inherited;
    UpdateMenuItems(Self, GetParentMenu);
    FixMenuBiDiProblem(GetParentMenu);
  end;
end;

procedure TTntMenuItem.UpdateMenuString(ParentMenu: TMenu);
var
  ParentHandle: THandle;

  function NativeMenuTypeIsString: Boolean;
  var
    MenuItemInfo: TMenuItemInfoW;
    Buffer: array[0..79] of WideChar;
  begin
    MenuItemInfo.cbSize := 44; // Required for Windows NT 4.0
    MenuItemInfo.fMask := MIIM_TYPE;
    MenuItemInfo.dwTypeData := Buffer; // ??
    MenuItemInfo.cch := Length(Buffer); // ??
    Result := GetMenuItemInfoW(ParentHandle, Command, False, MenuItemInfo)
         and ((MenuItemInfo.fType and (MFT_BITMAP or MFT_SEPARATOR or MFT_OWNERDRAW)) = 0)
  end;

  function NativeMenuString: WideString;
  var
    Len: Integer;
  begin
    Assert(Win32PlatformIsUnicode);
    Len := GetMenuStringW(ParentHandle, Command, nil, 0, MF_BYCOMMAND);
    if Len = 0 then
      Result := ''
    else begin
      SetLength(Result, Len + 1);
      Len := GetMenuStringW(ParentHandle, Command, PWideChar(Result), Len + 1, MF_BYCOMMAND);
      SetLength(Result, Len);
    end;
  end;

  procedure SetMenuString(const Value: WideString);
  var
    MenuItemInfo: TMenuItemInfoW;
    Buffer: array[0..79] of WideChar;
  begin
    MenuItemInfo.cbSize := 44; // Required for Windows NT 4.0
    MenuItemInfo.fMask := MIIM_TYPE;
    MenuItemInfo.dwTypeData := Buffer; // ??
    MenuItemInfo.cch := Length(Buffer); // ??
    if GetMenuItemInfoW(ParentHandle, Command, False, MenuItemInfo)
    and ((MenuItemInfo.fType and (MFT_BITMAP or MFT_SEPARATOR or MFT_OWNERDRAW)) = 0) then
    begin
      MenuItemInfo.dwTypeData := PWideChar(Value);
      MenuItemInfo.cch := Length(Value);
      Win32Check(SetMenuItemInfoW(ParentHandle, Command, False, MenuItemInfo));
    end;
  end;

  function SameEvent(A, B: TMenuMeasureItemEvent): Boolean;
  begin
    Result := @A = @B;
  end;

var
  MenuCaption: WideString;
begin
  if Parent = nil then
    ParentHandle := 0
  else if (THackMenuItem(Self.Parent).FMergedWith <> nil) then
    ParentHandle := THackMenuItem(Self.Parent).FMergedWith.Handle
  else
    ParentHandle := Parent.Handle;

  if (Win32PlatformIsUnicode)
  and (Parent <> nil) and (ParentMenu <> nil)
  and (ComponentState * [csReading, csDestroying] = [])
  and (Visible)
  and (NativeMenuTypeIsString) then begin
    MenuCaption := Caption;
    if (Count = 0)
    and ((ShortCut <> scNone)
    and ((Parent = nil) or (Parent.Parent <> nil) or not (Parent.Owner is TMainMenu{TNT-ALLOW TMainMenu}))) then
      MenuCaption := MenuCaption + #9 + WideShortCutToText(ShortCut);
    if (NativeMenuString <> MenuCaption) then
    begin
      SetMenuString(MenuCaption);
      if  ((Parent = ParentMenu.Items) or (THackMenuItem(Self.Parent).FMergedWith <> nil))
      and (ParentMenu is TMainMenu{TNT-ALLOW TMainMenu})
      and (ParentMenu.WindowHandle <> 0) then
        DrawMenuBar(ParentMenu.WindowHandle) {top level menu bar items}
    end;
  end;
end;

function TTntMenuItem.GetAlignmentDrawStyle: Word;
const
  Alignments: array[TPopupAlignment] of Word = (DT_LEFT, DT_RIGHT, DT_CENTER);
var
  ParentMenu: TMenu;
  Alignment: TPopupAlignment;
begin
  ParentMenu := GetParentMenu;
  if ParentMenu is TMenu then
    Alignment := paLeft
  else if ParentMenu is TPopupMenu{TNT-ALLOW TPopupMenu} then
    Alignment := TPopupMenu{TNT-ALLOW TPopupMenu}(ParentMenu).Alignment
  else
    Alignment := paLeft;
  Result := Alignments[Alignment];
end;

procedure TTntMenuItem.AdvancedDrawItem(ACanvas: TCanvas; ARect: TRect;
  State: TOwnerDrawState; TopLevel: Boolean);