SHARE
TWEET

uStandardizeFonts containing working StandardizeFormFont

wprins Sep 22nd, 2015 (edited) 768 Never
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
  1. unit uStandardizeFonts;
  2.  
  3. // 2015-09-21 Walter Prins, original code (c) Ian Boyd
  4. //
  5. // Unit assembled from original code by Ian Boyd on this page on Stack Overflow:
  6. //   http://stackoverflow.com/questions/8296784/how-do-i-make-my-gui-behave-well-when-windows-font-scaling-is-greater-than-100
  7. //
  8. // Purpose: Provides routines that attempts to properly scale forms/controls
  9. //   based on user font and display settings.
  10. //
  11. // Minimal usage: Set form "Scaled" property to False on all forms and call
  12. //   StandardizeFormFont() from the OnCreate (or perhaps an overridden form
  13. //   Constructor()).
  14. //
  15. // Also advisable: Standardize your forms at designtime to use Segoe UI
  16. //   font, ensure developer machines Windows setup is to use 100% sized fonts.
  17. //   [Note Segoe UI is the default system font on Windows since Windows Vista.]
  18. //   If you'd like to keep Scaled set to True for any reason then this can be
  19. //   made to work by also then overriding the protected ChangeScale() method on
  20. //   each such form. Quote from Ian Boyd:
  21. //     "Inside ChangeScale is where i keep a running
  22. //        FCurrentScaleFactor := FCurrentScaleFactor * M/D
  23. //      so i always know my current runtime scaling.
  24. //      If you ever try to position things with hard-coded pixel values,
  25. //      you should actually [instead] be doing something like
  26. //        Button1.Top := Round(Self.Top + 16*FCurrentScaleFactor);
  27. //      so you're not using hard-coded pixels."  -- Ian Boyd May 30 '14 at 21:26
  28. //
  29. // Other Notes:
  30. // - Briefly tested on XE, XE8. Should work on anything XE and beyond.
  31. // - Depends on JvComputerInfoEx from the JEDI JCL/JVCL libraries.
  32. //   The latest version can be obtained from http://jvcl.delphi-jedi.org
  33. //   or directly from GitHub:
  34. //     https://github.com/project-jedi/jvcl/blob/master/jvcl/run/JvComputerInfoEx.pas//
  35. // - Note that the unit will force adjust the fonts/size to be larger than normal
  36. //   *when run under the IDE/debugger*, presumably as a dogfooding excercise to
  37. //   enable you as developer to see how the resizing looks/works.
  38. // - Note also that it will check whether Scaled is set properly, and will also
  39. //   auto-enable hints if hint text is present but hints are in fact disabled.
  40. //   When run under the IDE it will then trigger a debugger breakpoint when
  41. //   these corrective actions are taken to alert you to this fact that some
  42. //   designtime corrections might be desired.
  43. //
  44. // Modifications/Additions:
  45. // - Modified GetUserFontPreference to use TJvSystemParametersInfo in order to
  46. //   obtain the IconTitleFont (to replace call to missing GetIconTitleFont()
  47. //   in original code).
  48. // - Implemented missing GetControlFont() via new style RTTI.
  49. // - Added some comments, some reformatting.
  50.  
  51. interface
  52.  
  53. uses
  54.   Forms
  55.   , Controls //for TControl
  56.   , Graphics //for TFont
  57.   ;
  58.  
  59. var
  60.   g_ForceClearType: Boolean = False;
  61.   // To force ClearType on, set this to True or $define ForceClearType
  62.  
  63. function StandardizeFormFont(AForm: TForm): Real; overload;
  64. function StandardizeFormFont(AForm: TForm; FontName: string; FontHeight: Integer): Real; overload;
  65.  
  66. procedure GetUserFontPreference(out FaceName: string; out PixelHeight: Integer);
  67. function GetControlFont(AControl: TControl): TFont;
  68.  
  69. implementation
  70.  
  71. uses
  72.   Windows
  73.   , SysUtils
  74.   , Classes
  75.   , ComCtrls
  76.   , RTTI
  77.   , MultiMon
  78.   , Math
  79.   , JvComputerInfoEx
  80.   ;
  81.  
  82. type
  83.   TAnchorsArray = array of TAnchors;
  84.  
  85. procedure StandardizeFont_ControlFontCore(AControlFont: TFont; ForceClearType:
  86.   Boolean;
  87.   FontName: string; FontSize: Integer;
  88.   ForceFontIfName: string; ForceFontIfSize: Integer);
  89. const
  90.   CLEARTYPE_QUALITY = 5;
  91. var
  92.   CanChangeName: Boolean;
  93.   CanChangeSize: Boolean;
  94.   lf: TLogFont;
  95. begin
  96.   if not Assigned(AControlFont) then
  97.     Exit;
  98.  
  99. {$IFDEF ForceClearType}
  100.   ForceClearType := True;
  101. {$ELSE}
  102.   if g_ForceClearType then
  103.     ForceClearType := True;
  104. {$ENDIF}
  105.  
  106.   //Standardize the font if it's currently
  107.   //  "MS Shell Dlg 2" (meaning whoever it was opted into the 'change me' system
  108.   //  "MS Sans Serif" (the Delphi default)
  109.   //  "Tahoma" (when they wanted to match the OS, but "MS Shell Dlg 2" should have been used)
  110.   //  "MS Shell Dlg" (the 9x name)
  111.   CanChangeName :=
  112.     (FontName <> '')
  113.     and (AControlFont.Name <> FontName)
  114.     and (( (ForceFontIfName <> '')
  115.            and (AControlFont.Name = ForceFontIfName)
  116.          )
  117.          or
  118.          ((ForceFontIfName = '')
  119.          and ((AControlFont.Name = 'MS Sans Serif')
  120.               or (AControlFont.Name = 'Tahoma')
  121.               or (AControlFont.Name = 'MS Shell Dlg 2')
  122.               or (AControlFont.Name = 'MS Shell Dlg')
  123.              )
  124.          )
  125.         );
  126.  
  127.   CanChangeSize :=
  128.     (//there is a font size
  129.      (FontSize <> 0)
  130.      and (//the font is at it's default size, or we're specifying what it's default size is
  131.            (AControlFont.Size = 8)
  132.            or
  133.            ((ForceFontIfSize <> 0) and (AControlFont.Size = ForceFontIfSize))
  134.          )
  135.      and (//the font size (or height) is not equal
  136.            //negative for height (px)
  137.            ((FontSize < 0) and (AControlFont.Height <> FontSize))
  138.            or//positive for size (pt)
  139.            ((FontSize > 0) and (AControlFont.Size <> FontSize))
  140.          )
  141.      and (//no point in using default font's size if they're not using the face
  142.            (AControlFont.Name = FontName)
  143.            or CanChangeName
  144.          )
  145.     );
  146.  
  147.   if CanChangeName or CanChangeSize or ForceClearType then
  148.   begin
  149.     if GetObject(AControlFont.Handle, SizeOf(TLogFont), @lf) <> 0 then
  150.     begin
  151.       //Change the font attributes and put it back
  152.       if CanChangeName then
  153.         StrPLCopy(Addr(lf.lfFaceName[0]), FontName, LF_FACESIZE);
  154.       if CanChangeSize then
  155.         lf.lfHeight := FontSize;
  156.  
  157.       if ForceClearType then
  158.         lf.lfQuality := CLEARTYPE_QUALITY;
  159.       AControlFont.Handle := CreateFontIndirect(lf);
  160.     end
  161.     else
  162.     begin
  163.       if CanChangeName then
  164.         AControlFont.Name := FontName;
  165.       if CanChangeSize then
  166.       begin
  167.         if FontSize > 0 then
  168.           AControlFont.Size := FontSize
  169.         else if FontSize < 0 then
  170.           AControlFont.Height := FontSize;
  171.       end;
  172.     end;
  173.   end;
  174. end;
  175.  
  176. procedure EnableAnchors_Core(ParentControl: TWinControl; aAnchorStorage:
  177.   TAnchorsArray; var StartingIndex: Integer);
  178. var
  179.   iCounter: integer;
  180.   ChildControl: TControl;
  181. begin
  182.   for iCounter := 0 to ParentControl.ControlCount - 1 do
  183.   begin
  184.     ChildControl := ParentControl.Controls[iCounter];
  185.     ChildControl.Anchors := aAnchorStorage[StartingIndex];
  186.  
  187.     Inc(StartingIndex);
  188.   end;
  189.  
  190.   //Restore children
  191.   for iCounter := 0 to ParentControl.ControlCount - 1 do
  192.   begin
  193.     ChildControl := ParentControl.Controls[iCounter];
  194.     if ChildControl is TWinControl then
  195.       EnableAnchors_Core(TWinControl(ChildControl), aAnchorStorage,
  196.         StartingIndex);
  197.   end;
  198. end;
  199.  
  200. procedure EnableAnchors(ParentControl: TWinControl; aAnchorStorage:
  201.   TAnchorsArray);
  202. var
  203.   StartingIndex: Integer;
  204. begin
  205.   StartingIndex := 0;
  206.   EnableAnchors_Core(ParentControl, aAnchorStorage, StartingIndex);
  207. end;
  208.  
  209. procedure DisableAnchors_Core(ParentControl: TWinControl; var aAnchorStorage:
  210.   TAnchorsArray; var StartingIndex: Integer);
  211. var
  212.   iCounter: integer;
  213.   ChildControl: TControl;
  214. begin
  215.   if (StartingIndex + ParentControl.ControlCount + 1) > (Length(aAnchorStorage))
  216.     then
  217.     SetLength(aAnchorStorage, StartingIndex + ParentControl.ControlCount + 1);
  218.  
  219.   for iCounter := 0 to ParentControl.ControlCount - 1 do
  220.   begin
  221.     ChildControl := ParentControl.Controls[iCounter];
  222.     aAnchorStorage[StartingIndex] := ChildControl.Anchors;
  223.  
  224.     //doesn't work for set of stacked top-aligned panels
  225. //      if ([akRight, akBottom ] * ChildControl.Anchors) <> [] then
  226. //          ChildControl.Anchors := [akLeft, akTop];
  227.  
  228.     if (ChildControl.Anchors) <> [akTop, akLeft] then
  229.       ChildControl.Anchors := [akLeft, akTop];
  230.  
  231. //      if ([akTop, akBottom] * ChildControl.Anchors) = [akTop, akBottom] then
  232. //          ChildControl.Anchors := ChildControl.Anchors - [akBottom];
  233.  
  234.     Inc(StartingIndex);
  235.   end;
  236.  
  237.   //Add children
  238.   for iCounter := 0 to ParentControl.ControlCount - 1 do
  239.   begin
  240.     ChildControl := ParentControl.Controls[iCounter];
  241.     if ChildControl is TWinControl then
  242.       DisableAnchors_Core(TWinControl(ChildControl), aAnchorStorage,
  243.         StartingIndex);
  244.   end;
  245. end;
  246.  
  247. function DisableAnchors(ParentControl: TWinControl): TAnchorsArray;
  248. var
  249.   StartingIndex: Integer;
  250. begin
  251.   StartingIndex := 0;
  252.   DisableAnchors_Core(ParentControl, Result, StartingIndex);
  253. end;
  254.  
  255. function GetControlFont(AControl: TControl): TFont;
  256. var
  257.   ctx: TRttiContext;
  258.   t: TRttiType;
  259.   p: TRttiProperty;
  260. begin
  261.   Result := nil;
  262.   ctx := TRttiContext.Create;
  263.   try
  264.     t := ctx.GetType(AControl.ClassType);
  265.     p := t.GetProperty('Font');
  266.     if Assigned(p) then
  267.     begin
  268.       t := p.PropertyType;
  269.       if (t.AsInstance.MetaclassType.InheritsFrom(TFont)) then
  270.       begin
  271.         Result := p.GetValue(AControl).AsObject as TFont;
  272.       end;
  273.     end;
  274.   finally
  275.     ctx.Free;
  276.   end;
  277. end;
  278.  
  279. procedure StandardizeFont_ControlCore(AControl: TControl; ForceClearType:
  280.   Boolean;
  281.   FontName: string; FontSize: Integer;
  282.   ForceFontIfName: string; ForceFontIfSize: Integer);
  283. const
  284.   CLEARTYPE_QUALITY = 5;
  285. var
  286.   i: Integer;
  287.   RunComponent: TComponent;
  288.   AControlFont: TFont;
  289. begin
  290.   if not Assigned(AControl) then
  291.     Exit;
  292.  
  293.   if (AControl is TStatusBar) then
  294.   begin
  295.     TStatusBar(AControl).UseSystemFont := False; //force...
  296.     TStatusBar(AControl).UseSystemFont := True; //...it
  297.   end
  298.   else
  299.   begin
  300.     AControlFont := GetControlFont(AControl);
  301.  
  302.     if not Assigned(AControlFont) then
  303.       Exit;
  304.  
  305.     StandardizeFont_ControlFontCore(AControlFont, ForceClearType,
  306.       FontName, FontSize,
  307.       ForceFontIfName, ForceFontIfSize);
  308.   end;
  309.  
  310.   {   If a panel has a toolbar on it, the toolbar won't paint properly. So this idea won't work.
  311.       if (not Toolkit.IsRemoteSession) and (AControl is TWinControl) and (not (AControl is TToolBar)) then
  312.           TWinControl(AControl).DoubleBuffered := True;
  313.   }
  314.  
  315.   //Iterate children
  316.   for i := 0 to AControl.ComponentCount - 1 do
  317.   begin
  318.     RunComponent := AControl.Components[i];
  319.     if RunComponent is TControl then
  320.       StandardizeFont_ControlCore(
  321.         TControl(RunComponent), ForceClearType,
  322.         FontName, FontSize,
  323.         ForceFontIfName, ForceFontIfSize);
  324.   end;
  325. end;
  326.  
  327. procedure ScaleForm(const AForm: TForm; const M, D: Integer);
  328. var
  329.   aAnchorStorage: TAnchorsArray;
  330.   RectBefore, RectAfter: TRect;
  331.   x, y: Integer;
  332.   monitorInfo: TMonitorInfo;
  333.   workArea: TRect;
  334. begin
  335.   if (M = 0) and (D = 0) then
  336.     Exit;
  337.  
  338.   RectBefore := AForm.BoundsRect;
  339.  
  340.   SetLength(aAnchorStorage, 0);
  341.   aAnchorStorage := DisableAnchors(AForm);
  342.   try
  343.     AForm.ScaleBy(M, D);
  344.   finally
  345.     EnableAnchors(AForm, aAnchorStorage);
  346.   end;
  347.  
  348.   RectAfter := AForm.BoundsRect;
  349.  
  350.   case AForm.Position of
  351.     poScreenCenter, poDesktopCenter, poMainFormCenter, poOwnerFormCenter,
  352.       poDesigned: //i think i really want everything else to also follow the nudging rules...why did i exclude poDesigned
  353.       begin
  354.         //This was only nudging by one quarter the difference, rather than one half the difference
  355. //      x := RectAfter.Left - ((RectAfter.Right-RectBefore.Right) div 2);
  356. //      y := RectAfter.Top - ((RectAfter.Bottom-RectBefore.Bottom) div 2);
  357.         x := RectAfter.Left - ((RectAfter.Right - RectAfter.Left) -
  358.           (RectBefore.Right - RectBefore.Left)) div 2;
  359.         y := RectAfter.Top - ((RectAfter.Bottom - RectAfter.Top) -
  360.           (RectBefore.Bottom - RectBefore.Top)) div 2;
  361.       end;
  362.   else
  363.     //poDesigned, poDefault, poDefaultPosOnly, poDefaultSizeOnly:
  364.     x := RectAfter.Left;
  365.     y := RectAfter.Top;
  366.   end;
  367.  
  368.   if AForm.Monitor <> nil then
  369.   begin
  370.     monitorInfo.cbSize := SizeOf(monitorInfo);
  371.     if GetMonitorInfo(AForm.Monitor.Handle, @monitorInfo) then
  372.       workArea := monitorInfo.rcWork
  373.     else
  374.     begin
  375.       OutputDebugString(PChar(SysErrorMessage(GetLastError)));
  376.       workArea := Rect(AForm.Monitor.Left, AForm.Monitor.Top, AForm.Monitor.Left
  377.         + AForm.Monitor.Width, AForm.Monitor.Top + AForm.Monitor.Height);
  378.     end;
  379.  
  380.     //If the form is off the right or bottom of the screen then we need to pull it back
  381.     if RectAfter.Right > workArea.Right then
  382.       x := workArea.Right - (RectAfter.Right - RectAfter.Left); //rightEdge - widthOfForm
  383.  
  384.     if RectAfter.Bottom > workArea.Bottom then
  385.       y := workArea.Bottom - (RectAfter.Bottom - RectAfter.Top);//bottomEdge - heightOfForm
  386.  
  387.     x := Max(x, workArea.Left); //don't go beyond left edge
  388.     y := Max(y, workArea.Top);  //don't go above top edge
  389.   end
  390.   else
  391.   begin
  392.     x := Max(x, 0); //don't go beyond left edge
  393.     y := Max(y, 0); //don't go above top edge
  394.   end;
  395.  
  396.   AForm.SetBounds(x, y,
  397.     RectAfter.Right - RectAfter.Left, //Width
  398.     RectAfter.Bottom - RectAfter.Top); //Height
  399. end;
  400.  
  401. function GetControlName(AControl: TControl): string;
  402. begin
  403.   result := AControl.Name;
  404. end;
  405.  
  406. function StandardizeFormFont(AForm: TForm; FontName: string; FontHeight:
  407.   Integer): Real; overload;
  408. var
  409.   oldHeight: Integer;
  410. begin
  411.   Assert(Assigned(AForm));
  412.  
  413.   if (AForm.Scaled) then
  414.   begin
  415.     OutputDebugString(PChar('WARNING: StandardizeFormFont: Form "' +
  416.       GetControlName(AForm) +
  417.       '" is set to Scaled. Proper form scaling requires VCL scaling to be disabled, unless you implement scaling by overriding the protected ChangeScale() method of the form.'));
  418.   end;
  419.  
  420.   if (AForm.AutoScroll) then
  421.   begin
  422.     if AForm.WindowState = wsNormal then
  423.     begin
  424.       OutputDebugString(PChar('WARNING: StandardizeFormFont: Form "' +
  425.         GetControlName(AForm) +
  426.         '" is set to AutoScroll. Form designed size will be suseptable to changes in Windows form caption height (e.g. 2000 vs XP).'));
  427.       if IsDebuggerPresent then
  428.         Windows.DebugBreak; //Some forms would like it (to fix maximizing problem)
  429.     end;
  430.   end;
  431.  
  432.   if (not AForm.ShowHint) then
  433.   begin
  434.     AForm.ShowHint := True;
  435.     OutputDebugString(PChar('INFORMATION: StandardizeFormFont: Turning on form "'
  436.       + GetControlName(AForm) + '" hints. (ShowHint := True)'));
  437.     if IsDebuggerPresent then
  438.       Windows.DebugBreak; //Some forms would like it (to fix maximizing problem)
  439.   end;
  440.  
  441.   oldHeight := AForm.Font.Height;
  442.  
  443.   //Scale the form to the new font size
  444.   //  if (FontHeight <> oldHeight) then  For compatibility, it's safer to trigger a call to ChangeScale, since a lot of people will be assuming it always is called
  445.   begin
  446.     ScaleForm(AForm, FontHeight, oldHeight);
  447.   end;
  448.  
  449.   //Now change all controls to actually use the new font
  450.   StandardizeFont_ControlCore(AForm, g_ForceClearType, FontName, FontHeight,
  451.     AForm.Font.Name, AForm.Font.Size);
  452.  
  453.   //Return the scaling ratio, so any hard-coded values can be multiplied
  454.   Result := FontHeight / oldHeight;
  455. end;
  456.  
  457. procedure GetUserFontPreference(out FaceName: string; out PixelHeight: Integer);
  458. var
  459.   font: TFont;
  460.   sysparams: TJvSystemParametersInfo;
  461. begin
  462.   sysparams := TJvSystemParametersInfo.Create();
  463.   try
  464.     font := sysparams.IconTitleFont;
  465.     FaceName := font.Name; //e.g. "Segoe UI"
  466.  
  467.     //Dogfood testing: use a larger font than we're used to; to force us to actually test it
  468.     if IsDebuggerPresent then
  469.       font.Size := font.Size + 1;
  470.  
  471.     PixelHeight := font.Height; //e.g. -16
  472.   finally
  473.     sysparams.Free;
  474.   end;
  475. end;
  476.  
  477. function StandardizeFormFont(AForm: TForm): Real; overload;
  478. var
  479.   preferredFontName: string;
  480.   preferredFontHeight: Integer;
  481. begin
  482.   GetUserFontPreference({out}preferredFontName, {out} preferredFontHeight);
  483.  
  484.   //e.g. "Segoe UI",
  485.   Result := StandardizeFormFont(AForm, PreferredFontName, PreferredFontHeight);
  486. end;
  487.  
  488. end.
RAW Paste Data
We use cookies for various purposes including analytics. By continuing to use Pastebin, you agree to our use of cookies as described in the Cookies Policy. OK, I Understand
 
Top