From 33912bcbed54a40ec3e3cfccfacc86d39ab8fca1 Mon Sep 17 00:00:00 2001 From: leafOfTree Date: Sun, 18 Oct 2026 12:02:17 +0800 Subject: [PATCH] Show tab text at the system menu font size on scaled displays The tab font was scaled by the display DPI on top of the system DPI that GDI already applies to point sizes, so at 125% scale tab text came out a quarter too large. It now only follows a monitor whose scale differs from the system one. The drag-and-drop hint uses the same font as the other tab tooltips. --- WtProgram/OleDropTarget.fs | 2 +- WtProgram/TabStripSprite.fs | 3 ++- tests/TabShadow.fsx | 11 +++++++++++ 3 files changed, 14 insertions(+), 2 deletions(-) diff --git a/WtProgram/OleDropTarget.fs b/WtProgram/OleDropTarget.fs index d0facf48..b23732bd 100755 --- a/WtProgram/OleDropTarget.fs +++ b/WtProgram/OleDropTarget.fs @@ -56,7 +56,7 @@ type OleDropTarget(ts:TabStrip) as this= label <- Some tip tip let strip : Rect = ts.bounds - use font = System.Drawing.SystemFonts.MessageBoxFont + use font = TabMetrics.font 0 System.Drawing.FontStyle.Regular tip.show(text,font,System.Drawing.Rectangle(strip.x,strip.y,strip.size.width,strip.size.height),pointerX) let effectAt (keys:int) (pt:POINTL) (allowed:int) = diff --git a/WtProgram/TabStripSprite.fs b/WtProgram/TabStripSprite.fs index fc0ffd33..9cdfe3ff 100755 --- a/WtProgram/TabStripSprite.fs +++ b/WtProgram/TabStripSprite.fs @@ -93,8 +93,9 @@ module TabMetrics = /// A logical length (padding, gap, button) shrunk with the icon. let scaled (height:int) (logical:int) = max 1 (int(Math.Round(float(Dpi.scale logical) * scale height))) /// The menu font, made smaller only when its line would not fit the tab. 0 means any height. + /// GDI already sizes points at the system DPI, so only another monitor's scale is applied. let font (height:int) (style:FontStyle) = - let points = float32(Dpi.scaleF(float SystemFonts.MenuFont.SizeInPoints)) + let points = SystemFonts.MenuFont.SizeInPoints*float32(Dpi.value())/float32(Dpi.system()) use full = new Font(SystemFonts.MenuFont.FontFamily,points,style) let fit = if height>0 && full.Height>height then float32 height/float32 full.Height else 1.0f new Font(SystemFonts.MenuFont.FontFamily,max 1.0f (points*fit),style) diff --git a/tests/TabShadow.fsx b/tests/TabShadow.fsx index 483be2e6..bdbe9a29 100644 --- a/tests/TabShadow.fsx +++ b/tests/TabShadow.fsx @@ -271,6 +271,17 @@ let main () = check (flashing.GetPixel(x,flashing.Height/2).ToArgb()<>Color.Red.ToArgb()) "Vertical stripe overrode an attention color" check (Theme.tabTint true (Some Color.Red)=None) "High contrast retained tint" let tabImage = ts.render + // GDI already sizes points at the system DPI: tab text matches the menu font there and + // grows only in proportion on a monitor with another scale. + do + let before = Dpi.value() + try + for dpi,factor in [Dpi.system(),1.0f; Dpi.system()*2,2.0f] do + Dpi.set dpi + use font = TabMetrics.font 0 FontStyle.Regular + check (abs(font.SizeInPoints-SystemFonts.MenuFont.SizeInPoints*factor)<0.01f) + (sprintf "Tab font is %.2fpt at %d DPI with the system at %d DPI" font.SizeInPoints dpi (Dpi.system())) + finally Dpi.set before // Short tabs shrink their contents to fit instead of clipping them. for h in [12;18;26] do use font = TabMetrics.font h FontStyle.Regular