wprins

uStandardizeFonts containing working StandardizeFormFont

Sep 22nd, 2015
880
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

Adblocker detected! Please consider disabling it...

We've detected AdBlock Plus or some other adblocking software preventing Pastebin.com from fully loading.

We don't have any obnoxious sound, or popup ads, we actively block these annoying types of ads!

Please add Pastebin.com to your ad blocker whitelist or disable your adblocking software.

×