TMainMenu: Änderung der Schriftgröße ändert nicht den Abstand der Einträge

[KHJ]

Wenn ich die Schriftgröße des TMainMenu während der Laufzeit ändern will, dann muss ich das über Screen.MenuFont.Assign(EinFont) machen.
Das erfordert auch, dass IM Objektinspektor die Eigenschaft OwnerDraw := true setze.
Das funktioniert auch so weit.

Aber der Abstand zwischen den Menüeinträgen verändert sich nicht und dadurch sieht es unschön aus oder ist nicht mehr vollständig lesbar.

Ist das ein Bug?
Und wie kann ich das beheben?

Karlheinz

[Uwe Raabe]

Zitat:

Zitat von KHJ (Beitrag 1549531)

Ist das ein Bug?

Nein.

Zitat:

Zitat von KHJ (Beitrag 1549531)

Und wie kann ich das beheben?

In dem du die OnMeasureItem-Events der jeweiligen MenuItems sinnvoll implementierst.

[DaCoda]

So wie von Uwe schon angedeutet. Etwa so:

Code:

procedure TForm1.MainMenu1MeasureItem(Sender: TObject; ACanvas: TCanvas; var Width, Height: Integer);
begin
  // Weite und Höhe vom MenuItem
  Width := ACanvas.TextWidth('Custom Menu Item Text') + 20; // 20px Padding
  Height := ACanvas.TextHeight('Custom Menu Item Text') + 10; // 10px Padding
end;

[jaenicke]

Leider wird das alles nicht aufgerufen. Es kommt gar nicht erst WM_MEASUREITEM, so dass es keinerlei Unterschied macht, ob die Events zugewiesen sind oder nicht.

Auch DrawMenuBar usw. bringt nichts. Und die Möglichkeiten zur Neuerstellung des Handles sind so eingekapselt, dass man da nicht so einfach herankommt. So funktioniert es korrekt (zum Testen einfach die Typdeklaration über das Formular schreiben, damit unser TMenuItem statt dem aus Vcl.Menus verwendet wird):

Delphi-Quellcode:

type
  TMenuItem = class(Vcl.Menus.TMenuItem)
  public
    procedure Rebuild;
  end;

procedure CallByAddress(Instance: TObject; Address: Pointer);
type
  TRebuildHandleProc = procedure of object;
var
  Method: TMethod;
  Proc: TRebuildHandleProc;
begin
  Method.Code := Address;
  Method.Data := Instance;
  Proc := TRebuildHandleProc(Method);
  Proc;
end;

procedure TMenuItem.Rebuild;
begin
{$if CompilerVersion = 36}
  CallByAddress(Self, Pointer(NativeUInt(@TMenuItem.Insert) - $34B4));
{$else}
  {$message error 'Die Adresse muss für diese Delphiversion ggf. angepasst werden!'}
{$ifend}
  MenuChanged(True);
end;

Aufruf:

Delphi-Quellcode:

var
  i: Integer;
begin
  Screen.MenuFont.Size := 16;
  for i := 0 to MainMenu1.Items.Count - 1 do
    TMenuItem(MainMenu1.Items[i]).Rebuild;
end;

[KHJ]

Danke für die Tips.
Der einfachste Weg, der fast alles abdeckt:

Delphi-Quellcode:

  // set the menu font
  Screen.MenuFont.Assign(Self.Font);

  // push and redraw the menu by inserting and deleting a menu item
  lTempItem := TMenuItem.Create(mmuMainMenu);
  try
    lTempItem.Name := 'tempitem';
    mmuMainMenu.Items.Add(lTempItem);
    mmuMainMenu.Items.Remove(lTempItem);
  finally
    lTempItem.Free;
  end;

[KHJ]

Um nicht nur den Toplevel zu ändern, sondern auch alle Submenus:

Delphi-Quellcode:

  procedure RefreshMenuItem(aMenuItem: TMenuItem);
  var
    lTempItem: TMenuItem;
    i: Integer;
  begin

    lTempItem := TMenuItem.Create(aMenuItem);
    try
      lTempItem.Caption := 'tempitem';
      aMenuItem.Add(lTempItem);
      aMenuItem.Delete(aMenuItem.Count - 1);
    finally
      lTempItem.Free
    end;

    // and rekursiv through all sub menus of the current menu item
    for i := 0 to aMenuItem.Count - 1 do
    begin
      RefreshMenuItem(aMenuItem.Items[i]);
    end;
  end;

  procedure RefreshMainMenu(aMenu: TMainMenu);
  var
    i: Integer;
    lTempItem: TMenuItem;
  begin

    // toplevel
    lTempItem := TMenuItem.Create(aMenu);
    try
      lTempItem.Name := 'tempitem';
      aMenu.Items.Add(lTempItem);
      aMenu.Items.Remove(lTempItem);
    finally
      lTempItem.Free;
    end;

    // sublevels
    for i := 0 to aMenu.Items.Count - 1 do
    begin
      RefreshMenuItem(aMenu.Items[i]);
    end;
  end;

[Uwe Raabe]

Zitat:

Zitat von jaenicke (Beitrag 1549560)

Leider wird das alles nicht aufgerufen.

Das kommt schon, wenn man beim Menü das OwnerDraw auf True stellt. Diese Einstellung wurde auch im Eingangspost erwähnt.

[jaenicke]

Zitat:

Zitat von Uwe Raabe (Beitrag 1549572)

Das kommt schon, wenn man beim Menü das OwnerDraw auf True stellt.

Bei mir nicht, das habe ich schon alles versucht. Vermutlich ist das so, weil die Schriftart keine Änderung ist, die Windows kennt. Dementsprechend besteht systemseitig keine Notwendigkeit für eine erneute Größenberechnung.

Ich habe direkt geschaut, ob die Windows Messages ankommen. Das war nicht der Fall. Und entsprechend wurden auch die Haltepunkte in der Methode, die am Ende das Event aufruft, und an anderen Stellen nicht erreicht.

Ist das bei dir anders?

[Uwe Raabe]

Ist es in der Tat (Delphi 12.3 latest Patches, Windows 10 22H2).

[KHJ]

Zitat:

Zitat von Uwe Raabe (Beitrag 1549575)

Ist es in der Tat (Delphi 12.3 latest Patches, Windows 10 22H2).

On start up of the form yes, but not after a change of Screen.MenuFont.

Delphi-Quellcode:

procedure TForm1.Button1Click(Sender: TObject);
begin
 if FontDialog1.Execute then
 begin
   Self.Caption := Fontdialog1.Font.Name;
   Screen.MenuFont.Assign(FontDialog1.Font);
 end;
end;

procedure TForm1.File1MeasureItem(Sender: TObject; ACanvas: TCanvas; var Width,
    Height: Integer);
begin
//
end;

[jaenicke]

Zitat:

Zitat von Uwe Raabe (Beitrag 1549575)

Ist es in der Tat (Delphi 12.3 latest Patches, Windows 10 22H2).

Bei mir ist es Windows 11. Das heißt bei dir wird die Größe der Items direkt korrekt angezeigt, wenn du die Schriftart änderst?!?
Denn wenn dann MeasureItem aufgerufen wird, muss ja die Größe auch stimmen.

Hast du noch irgendetwas anderes im Projekt gemacht?

Bei mir kommt das MeasureItem nach wie vor, egal wo ich es teste, nur einmal beim Start, es sei denn ich nutze einen der gezeigten Tricks.

[KHJ]

Zitat:

Zitat von jaenicke (Beitrag 1549581)

Zitat:

Zitat von Uwe Raabe (Beitrag 1549575)

Ist es in der Tat (Delphi 12.3 latest Patches, Windows 10 22H2).

Bei mir ist es Windows 11. Das heißt bei dir wird die Größe der Items direkt korrekt angezeigt, wenn du die Schriftart änderst?!?
Denn wenn dann MeasureItem aufgerufen wird, muss ja die Größe auch stimmen.

Hast du noch irgendetwas anderes im Projekt gemacht?

Bei mir kommt das MeasureItem nach wie vor, egal wo ich es teste, nur einmal beim Start, es sei denn ich nutze einen der gezeigten Tricks.

Bei mir ist es die Konstellation wie bei Uwe (12.3 aktueller Patch Status und WIN10 aktuell Stand). Measure Items wird aber nur einmalig aufgerufen.
Mit der Lösung des einmaligen Add/Remove über alle Ebenen kann ich nach einer Fontänderung leben, da dies bei mir nur sehr, sehr selten aufgerufen wird. Die Skalierung aller Elemente funktioniert damit einwandfrei.
Mir ist das nur aufgefallen, da ich von TActionMainMenuBar auf TMainMenu umgestellt habe. TActionMainMenuBar hat leider einen Bug RSS-2675, der bisher von EMBA nicht behoben wurde.

[Uwe Raabe]

Zitat:

Zitat von KHJ (Beitrag 1549582)

Bei mir kommt das MeasureItem nach wie vor, egal wo ich es teste, nur einmal beim Start, es sei denn ich nutze einen der gezeigten Tricks.

Das ist hier in der Tat auch so. Das Problem scheint mir aber wohl eher die Resistenz der Menüzeilenhöhe zu sein, die sich jedweder Änderung widersetzt. Diese Art von Problemen kommt leider häufig bei nativen Windows Controls oder systemnahen Elementen vor.

Die Breite der Menüeinträge bekommt man schon mit etwas Aufwand hin, aber das reicht dann am Ende halt auch nicht.

[KHJ]

Einen Einfluss hat auch AutoHotKeys.
Nur in der Einstellung AutoHotKeys := maAutomatic und OwnerDraw := true funktioniert bei mir DrawMenuBar(Handle).