DelphiシアトルでランタイムDPIを変更した後のメニューのスケーリング方法

Question

ランタイムDPI切り替えのサポートがフォームクラスに追加されたとき、メニューなどの基本的なUI要素は考慮されていませんでした。

Menu描画は、Screen.MenuFontに依存しているため、基本的には壊れています.Screen.MenuFontは、というシステムワイドメトリックであり、モニタ固有のものではありません。したがって、フォーム自体は比較的単純に適切に拡大縮小できますが、その上に表示されるメニューは、ScalingがScreenオブジェクトにロードされたメトリックに一致する場合にのみ正しく機能します。

これは、メインメニューバー、ポップアップメニュー、およびフォーム上のすべてのポップアップメニューの問題です。フォームがシステムメトリックとは異なるDPIを持つモニターに移動される場合は、これらのスケールはありません。

この作業を実際に行う唯一の方法は、VCLを修正することです。 EmbarcaderoがマルチDPIをフルに活用するのを待つことは、実際の選択肢ではありません。

VCLコードを見ると、メニューが表示されるモニターに適したフォントを選択するのではなく、Screen.MenuFontプロパティがメニューキャンバスに割り当てられるという基本的な問題があります。影響を受けるクラスは、VCLソースのScreen.MenuFontを検索するだけで見つけることができます。

関連するクラスを完全に書き直すことなく、この制限を回避する正しい方法は何ですか？

私の最初の傾きは、メニューポップアップを追跡し、メニューのセットアップに使用されているときにScreen.MenuFontプロパティを上書きするために迂回路を使用することです。それはあまりにも多くのハックのようだ。

Answer 1

ここでは現在作業中のソリューションの1つです。 Delphi Detours Libraryを使用して、このユニットをdpr usesリストに追加すると（他のフォームの前にリストの最上部に置く必要がありました）、メニュー項目を保持するフォームに基づいて正しいフォントサイズがメニューキャンバスに適用されますポップアップメニューでこのソリューションは、VCLが所有者が測定したアイテムを適切に処理しないため、上部メニュー（メニューバー）を意図的に無視します。

unit slMenuDPIFix; 

// add this unit to the main application dpr file BEFORE ANY FORMS in the uses list. 

interface 

implementation 

uses 
    Winapi.Windows, System.Classes, Vcl.Graphics, 
    Vcl.Controls, Vcl.Forms, Vcl.Menus, slScaleUtils, Math, 
    DDetours; 

type 
    TMenuClass = class(TMenu); 
    TMenuItemClass = class(TMenuItem); 

var 
    TrampolineMenuCreate: procedure(const Self: TMenuClass; AOwner: TComponent) = nil; 
    TrampolineMenuItemAdvancedDrawItem: procedure(const Self: TMenuItemClass; ACanvas: TCanvas; ARect: TRect; State: TOwnerDrawState; TopLevel: Boolean) = nil; 
    TrampolineMenuItemMeasureItem: procedure(const Self: TMenuItemClass; ACanvas: TCanvas; var Width, Height: Integer) = nil; 

function GetPopupDPI(const MenuItem: TMenuItemClass): Integer; 
var 
    pm: TMenu; 
    pcf: TCustomForm; 
begin 
    Result := Screen.PixelsPerInch; 
    pm := MenuItem.GetParentMenu; 
    if Assigned(pm) and (pm.Owner is TControl) then 
    pcf := GetParentForm(TControl(pm.Owner)) 
    else 
    pcf := nil; 
    if Assigned(pcf) and (pcf is TForm) then 
    Result := TForm(pcf).PixelsPerInch; 
end; 

procedure MenuCreateHooked(const Self: TMenuClass; AOwner: TComponent); 
begin 
    TrampolineMenuCreate(Self, AOwner); 
    Self.OwnerDraw := True;  // force always ownerdraw. 
end; 

procedure MenuItemAdvancedDrawItemHooked(const Self: TMenuItemClass; ACanvas: TCanvas; ARect: TRect; State: TOwnerDrawState; TopLevel: Boolean); 
begin 
    if (not TopLevel) then 
    begin 
    ACanvas.Font.Height := MulDiv(ACanvas.Font.Height, GetPopupDPI(Self), Screen.PixelsPerInch); 
    end; 
    TrampolineMenuItemAdvancedDrawItem(Self, ACanvas, ARect, State, TopLevel); 
end; 

procedure MenuItemMeasureItemHooked(const Self: TMenuItemClass; ACanvas: TCanvas; var Width, Height: Integer); 
var 
    lHeight: Integer; 
    pdpi: Integer; 
begin 
    pdpi := GetPopupDPI(Self); 
    if (Self.Caption <> cLineCaption) and (pdpi <> Screen.PixelsPerInch) then 
    begin 
    ACanvas.Font.Height := MulDiv(ACanvas.Font.Height, pdpi, Screen.PixelsPerInch); 
    lHeight := ACanvas.TextHeight('|') + MulDiv(6, pdpi, Screen.PixelsPerInch); 
    end else 
    lHeight := 0; 

    TrampolineMenuItemMeasureItem(Self, ACanvas, Width, Height); 

    if lHeight > 0 then 
    Height := Max(Height, lHeight); 
end; 

initialization 

    TrampolineMenuCreate := InterceptCreate(@TMenuClass.Create, @MenuCreateHooked); 
    TrampolineMenuItemAdvancedDrawItem := InterceptCreate(@TMenuItemClass.AdvancedDrawItem, @MenuItemAdvancedDrawItemHooked); 
    TrampolineMenuItemMeasureItem := InterceptCreate(@TMenuItemClass.MeasureItem, @MenuItemMeasureItemHooked); 

finalization 

    InterceptRemove(@TrampolineMenuCreate); 
    InterceptRemove(@TrampolineMenuItemAdvancedDrawItem); 
    InterceptRemove(@TrampolineMenuItemMeasureItem); 

end. 

Vcl.Menusに簡単にパッチを当てることもできますが、私はそれをしたくありませんでした。