Advertisement
Not a member of Pastebin yet?
Sign Up,
it unlocks many cool features!
- 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.
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement