uStandardizeFonts containing working StandardizeFormFont

unit uStandardizeFonts;

// 2015-09-21 Walter Prins, original code (c) Ian Boyd
//
// Unit assembled from original code by Ian Boyd on this page on Stack Overflow:
//   http://stackoverflow.com/questions/8296784/how-do-i-make-my-gui-behave-well-when-windows-font-scaling-is-greater-than-100
//
// Purpose: Provides routines that attempts to properly scale forms/controls
//   based on user font and display settings.
//
// Minimal usage: Set form "Scaled" property to False on all forms and call
//   StandardizeFormFont() from the OnCreate (or perhaps an overridden form
//   Constructor()).
//
// Also advisable: Standardize your forms at designtime to use Segoe UI
//   font, ensure developer machines Windows setup is to use 100% sized fonts.
//   [Note Segoe UI is the default system font on Windows since Windows Vista.]
//   If you'd like to keep Scaled set to True for any reason then this can be
//   made to work by also then overriding the protected ChangeScale() method on
//   each such form. Quote from Ian Boyd:
//     "Inside ChangeScale is where i keep a running
//        FCurrentScaleFactor := FCurrentScaleFactor * M/D
//      so i always know my current runtime scaling.
//      If you ever try to position things with hard-coded pixel values,
//      you should actually [instead] be doing something like
//        Button1.Top := Round(Self.Top + 16*FCurrentScaleFactor);
//      so you're not using hard-coded pixels."  -- Ian Boyd May 30 '14 at 21:26
//
// Other Notes:
// - Briefly tested on XE, XE8. Should work on anything XE and beyond.
// - Depends on JvComputerInfoEx from the JEDI JCL/JVCL libraries.
//   The latest version can be obtained from http://jvcl.delphi-jedi.org
//   or directly from GitHub:
//     https://github.com/project-jedi/jvcl/blob/master/jvcl/run/JvComputerInfoEx.pas//
// - Note that the unit will force adjust the fonts/size to be larger than normal
//   *when run under the IDE/debugger*, presumably as a dogfooding excercise to
//   enable you as developer to see how the resizing looks/works.
// - Note also that it will check whether Scaled is set properly, and will also
//   auto-enable hints if hint text is present but hints are in fact disabled.
//   When run under the IDE it will then trigger a debugger breakpoint when
//   these corrective actions are taken to alert you to this fact that some
//   designtime corrections might be desired.
//
// Modifications/Additions:
// - Modified GetUserFontPreference to use TJvSystemParametersInfo in order to
//   obtain the IconTitleFont (to replace call to missing GetIconTitleFont()
//   in original code).
// - Implemented missing GetControlFont() via new style RTTI.
// - Added some comments, some reformatting.

interface

uses
  Forms
  , Controls //for TControl
  , Graphics //for TFont
  ;

var
  g_ForceClearType: Boolean = False;
  // To force ClearType on, set this to True or $define ForceClearType

function StandardizeFormFont(AForm: TForm): Real; overload;
function StandardizeFormFont(AForm: TForm; FontName: string; FontHeight: Integer): Real; overload;

procedure GetUserFontPreference(out FaceName: string; out PixelHeight: Integer);
function GetControlFont(AControl: TControl): TFont;

implementation

uses
  Windows
  , SysUtils
  , Classes
  , ComCtrls
  , RTTI
  , MultiMon
  , Math
  , JvComputerInfoEx
  ;

type
  TAnchorsArray = array of TAnchors;

procedure StandardizeFont_ControlFontCore(AControlFont: TFont; ForceClearType:
  Boolean;
  FontName: string; FontSize: Integer;
  ForceFontIfName: string; ForceFontIfSize: Integer);
const
  CLEARTYPE_QUALITY = 5;
var
  CanChangeName: Boolean;
  CanChangeSize: Boolean;
  lf: TLogFont;
begin
  if not Assigned(AControlFont) then
    Exit;

{$IFDEF ForceClearType}
  ForceClearType := True;
{$ELSE}
  if g_ForceClearType then
    ForceClearType := True;
{$ENDIF}

  //Standardize the font if it's currently
  //  "MS Shell Dlg 2" (meaning whoever it was opted into the 'change me' system
  //  "MS Sans Serif" (the Delphi default)
  //  "Tahoma" (when they wanted to match the OS, but "MS Shell Dlg 2" should have been used)
  //  "MS Shell Dlg" (the 9x name)
  CanChangeName :=
    (FontName <> '')
    and (AControlFont.Name <> FontName)
    and (( (ForceFontIfName <> '')
           and (AControlFont.Name = ForceFontIfName)
         )
         or
         ((ForceFontIfName = '')
         and ((AControlFont.Name = 'MS Sans Serif')
              or (AControlFont.Name = 'Tahoma')
              or (AControlFont.Name = 'MS Shell Dlg 2')
              or (AControlFont.Name = 'MS Shell Dlg')
             )
         )
        );

  CanChangeSize :=
    (//there is a font size
     (FontSize <> 0)
     and (//the font is at it's default size, or we're specifying what it's default size is
           (AControlFont.Size = 8)
           or
           ((ForceFontIfSize <> 0) and (AControlFont.Size = ForceFontIfSize))
         )
     and (//the font size (or height) is not equal
           //negative for height (px)
           ((FontSize < 0) and (AControlFont.Height <> FontSize))
           or//positive for size (pt)
           ((FontSize > 0) and (AControlFont.Size <> FontSize))
         )
     and (//no point in using default font's size if they're not using the face
           (AControlFont.Name = FontName)
           or CanChangeName
         )
    );

  if CanChangeName or CanChangeSize or ForceClearType then
  begin
    if GetObject(AControlFont.Handle, SizeOf(TLogFont), @lf) <> 0 then
    begin
      //Change the font attributes and put it back
      if CanChangeName then
        StrPLCopy(Addr(lf.lfFaceName[0]), FontName, LF_FACESIZE);
      if CanChangeSize then
        lf.lfHeight := FontSize;

      if ForceClearType then
        lf.lfQuality := CLEARTYPE_QUALITY;
      AControlFont.Handle := CreateFontIndirect(lf);
    end
    else
    begin
      if CanChangeName then
        AControlFont.Name := FontName;
      if CanChangeSize then
      begin
        if FontSize > 0 then
          AControlFont.Size := FontSize
        else if FontSize < 0 then
          AControlFont.Height := FontSize;
      end;
    end;
  end;
end;

procedure EnableAnchors_Core(ParentControl: TWinControl; aAnchorStorage:
  TAnchorsArray; var StartingIndex: Integer);
var
  iCounter: integer;
  ChildControl: TControl;
begin
  for iCounter := 0 to ParentControl.ControlCount - 1 do
  begin
    ChildControl := ParentControl.Controls[iCounter];
    ChildControl.Anchors := aAnchorStorage[StartingIndex];

    Inc(StartingIndex);
  end;

  //Restore children
  for iCounter := 0 to ParentControl.ControlCount - 1 do
  begin
    ChildControl := ParentControl.Controls[iCounter];
    if ChildControl is TWinControl then
      EnableAnchors_Core(TWinControl(ChildControl), aAnchorStorage,
        StartingIndex);
  end;
end;

procedure EnableAnchors(ParentControl: TWinControl; aAnchorStorage:
  TAnchorsArray);
var
  StartingIndex: Integer;
begin
  StartingIndex := 0;
  EnableAnchors_Core(ParentControl, aAnchorStorage, StartingIndex);
end;

procedure DisableAnchors_Core(ParentControl: TWinControl; var aAnchorStorage:
  TAnchorsArray; var StartingIndex: Integer);
var
  iCounter: integer;
  ChildControl: TControl;
begin
  if (StartingIndex + ParentControl.ControlCount + 1) > (Length(aAnchorStorage))
    then
    SetLength(aAnchorStorage, StartingIndex + ParentControl.ControlCount + 1);

  for iCounter := 0 to ParentControl.ControlCount - 1 do
  begin
    ChildControl := ParentControl.Controls[iCounter];
    aAnchorStorage[StartingIndex] := ChildControl.Anchors;

    //doesn't work for set of stacked top-aligned panels
//      if ([akRight, akBottom ] * ChildControl.Anchors) <> [] then
//          ChildControl.Anchors := [akLeft, akTop];

    if (ChildControl.Anchors) <> [akTop, akLeft] then
      ChildControl.Anchors := [akLeft, akTop];

//      if ([akTop, akBottom] * ChildControl.Anchors) = [akTop, akBottom] then
//          ChildControl.Anchors := ChildControl.Anchors - [akBottom];

    Inc(StartingIndex);
  end;

  //Add children
  for iCounter := 0 to ParentControl.ControlCount - 1 do
  begin
    ChildControl := ParentControl.Controls[iCounter];
    if ChildControl is TWinControl then
      DisableAnchors_Core(TWinControl(ChildControl), aAnchorStorage,
        StartingIndex);
  end;
end;

function DisableAnchors(ParentControl: TWinControl): TAnchorsArray;
var
  StartingIndex: Integer;
begin
  StartingIndex := 0;
  DisableAnchors_Core(ParentControl, Result, StartingIndex);
end;

function GetControlFont(AControl: TControl): TFont;
var
  ctx: TRttiContext;
  t: TRttiType;
  p: TRttiProperty;
begin
  Result := nil;
  ctx := TRttiContext.Create;
  try
    t := ctx.GetType(AControl.ClassType);
    p := t.GetProperty('Font');
    if Assigned(p) then
    begin
      t := p.PropertyType;
      if (t.AsInstance.MetaclassType.InheritsFrom(TFont)) then
      begin
        Result := p.GetValue(AControl).AsObject as TFont;
      end;
    end;
  finally
    ctx.Free;
  end;
end;

procedure StandardizeFont_ControlCore(AControl: TControl; ForceClearType:
  Boolean;
  FontName: string; FontSize: Integer;
  ForceFontIfName: string; ForceFontIfSize: Integer);
const
  CLEARTYPE_QUALITY = 5;
var
  i: Integer;
  RunComponent: TComponent;
  AControlFont: TFont;
begin
  if not Assigned(AControl) then
    Exit;

  if (AControl is TStatusBar) then
  begin
    TStatusBar(AControl).UseSystemFont := False; //force...
    TStatusBar(AControl).UseSystemFont := True; //...it
  end
  else
  begin
    AControlFont := GetControlFont(AControl);

    if not Assigned(AControlFont) then
      Exit;

    StandardizeFont_ControlFontCore(AControlFont, ForceClearType,
      FontName, FontSize,
      ForceFontIfName, ForceFontIfSize);
  end;

  {   If a panel has a toolbar on it, the toolbar won't paint properly. So this idea won't work.
      if (not Toolkit.IsRemoteSession) and (AControl is TWinControl) and (not (AControl is TToolBar)) then
          TWinControl(AControl).DoubleBuffered := True;
  }

  //Iterate children
  for i := 0 to AControl.ComponentCount - 1 do
  begin
    RunComponent := AControl.Components[i];
    if RunComponent is TControl then
      StandardizeFont_ControlCore(
        TControl(RunComponent), ForceClearType,
        FontName, FontSize,
        ForceFontIfName, ForceFontIfSize);
  end;
end;

procedure ScaleForm(const AForm: TForm; const M, D: Integer);
var
  aAnchorStorage: TAnchorsArray;
  RectBefore, RectAfter: TRect;
  x, y: Integer;
  monitorInfo: TMonitorInfo;
  workArea: TRect;
begin
  if (M = 0) and (D = 0) then
    Exit;

  RectBefore := AForm.BoundsRect;

  SetLength(aAnchorStorage, 0);
  aAnchorStorage := DisableAnchors(AForm);
  try
    AForm.ScaleBy(M, D);
  finally
    EnableAnchors(AForm, aAnchorStorage);
  end;

  RectAfter := AForm.BoundsRect;

  case AForm.Position of
    poScreenCenter, poDesktopCenter, poMainFormCenter, poOwnerFormCenter,
      poDesigned: //i think i really want everything else to also follow the nudging rules...why did i exclude poDesigned
      begin
        //This was only nudging by one quarter the difference, rather than one half the difference
//      x := RectAfter.Left - ((RectAfter.Right-RectBefore.Right) div 2);
//      y := RectAfter.Top - ((RectAfter.Bottom-RectBefore.Bottom) div 2);
        x := RectAfter.Left - ((RectAfter.Right - RectAfter.Left) -
          (RectBefore.Right - RectBefore.Left)) div 2;
        y := RectAfter.Top - ((RectAfter.Bottom - RectAfter.Top) -
          (RectBefore.Bottom - RectBefore.Top)) div 2;
      end;
  else
    //poDesigned, poDefault, poDefaultPosOnly, poDefaultSizeOnly:
    x := RectAfter.Left;
    y := RectAfter.Top;
  end;

  if AForm.Monitor <> nil then
  begin
    monitorInfo.cbSize := SizeOf(monitorInfo);
    if GetMonitorInfo(AForm.Monitor.Handle, @monitorInfo) then
      workArea := monitorInfo.rcWork
    else
    begin
      OutputDebugString(PChar(SysErrorMessage(GetLastError)));
      workArea := Rect(AForm.Monitor.Left, AForm.Monitor.Top, AForm.Monitor.Left
        + AForm.Monitor.Width, AForm.Monitor.Top + AForm.Monitor.Height);
    end;

    //If the form is off the right or bottom of the screen then we need to pull it back
    if RectAfter.Right > workArea.Right then
      x := workArea.Right - (RectAfter.Right - RectAfter.Left); //rightEdge - widthOfForm

    if RectAfter.Bottom > workArea.Bottom then
      y := workArea.Bottom - (RectAfter.Bottom - RectAfter.Top);//bottomEdge - heightOfForm

    x := Max(x, workArea.Left); //don't go beyond left edge
    y := Max(y, workArea.Top);  //don't go above top edge
  end
  else
  begin
    x := Max(x, 0); //don't go beyond left edge
    y := Max(y, 0); //don't go above top edge
  end;

  AForm.SetBounds(x, y,
    RectAfter.Right - RectAfter.Left, //Width
    RectAfter.Bottom - RectAfter.Top); //Height
end;

function GetControlName(AControl: TControl): string;
begin
  result := AControl.Name;
end;

function StandardizeFormFont(AForm: TForm; FontName: string; FontHeight:
  Integer): Real; overload;
var
  oldHeight: Integer;
begin
  Assert(Assigned(AForm));

  if (AForm.Scaled) then
  begin
    OutputDebugString(PChar('WARNING: StandardizeFormFont: Form "' +
      GetControlName(AForm) +
      '" 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.'));
  end;

  if (AForm.AutoScroll) then
  begin
    if AForm.WindowState = wsNormal then
    begin
      OutputDebugString(PChar('WARNING: StandardizeFormFont: Form "' +
        GetControlName(AForm) +
        '" is set to AutoScroll. Form designed size will be suseptable to changes in Windows form caption height (e.g. 2000 vs XP).'));
      if IsDebuggerPresent then
        Windows.DebugBreak; //Some forms would like it (to fix maximizing problem)
    end;
  end;

  if (not AForm.ShowHint) then
  begin
    AForm.ShowHint := True;
    OutputDebugString(PChar('INFORMATION: StandardizeFormFont: Turning on form "'
      + GetControlName(AForm) + '" hints. (ShowHint := True)'));
    if IsDebuggerPresent then
      Windows.DebugBreak; //Some forms would like it (to fix maximizing problem)
  end;

  oldHeight := AForm.Font.Height;

  //Scale the form to the new font size
  //  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
  begin
    ScaleForm(AForm, FontHeight, oldHeight);
  end;

  //Now change all controls to actually use the new font
  StandardizeFont_ControlCore(AForm, g_ForceClearType, FontName, FontHeight,
    AForm.Font.Name, AForm.Font.Size);

  //Return the scaling ratio, so any hard-coded values can be multiplied
  Result := FontHeight / oldHeight;
end;

procedure GetUserFontPreference(out FaceName: string; out PixelHeight: Integer);
var
  font: TFont;
  sysparams: TJvSystemParametersInfo;
begin
  sysparams := TJvSystemParametersInfo.Create();
  try
    font := sysparams.IconTitleFont;
    FaceName := font.Name; //e.g. "Segoe UI"

    //Dogfood testing: use a larger font than we're used to; to force us to actually test it
    if IsDebuggerPresent then
      font.Size := font.Size + 1;

    PixelHeight := font.Height; //e.g. -16
  finally
    sysparams.Free;
  end;
end;

function StandardizeFormFont(AForm: TForm): Real; overload;
var
  preferredFontName: string;
  preferredFontHeight: Integer;
begin
  GetUserFontPreference({out}preferredFontName, {out} preferredFontHeight);

  //e.g. "Segoe UI",
  Result := StandardizeFormFont(AForm, PreferredFontName, PreferredFontHeight);
end;

end.