Es ist auch wichtig zu beachten, dass die Einhaltung der DPI des Benutzers nur eine Teilmenge Ihres eigentlichen Jobs ist:
Berücksichtigung der Schriftgröße des Benutzers
Seit Jahrzehnten löst Windows dieses Problem mit dem Gedanken, das Layout mithilfe von Dialogeinheiten anstelle von Pixeln durchzuführen . Eine "Dialogeinheit" ist so definiert, dass das durchschnittliche Zeichen der Schriftart ist
- 4 Dialogeinheiten (dlus) breit und
- 8 Dialogeinheiten (Clus) hoch
Delphi wird mit einer (fehlerhaften) Vorstellung von ausgeliefert Scaled, bei der ein Formular versucht, sich basierend auf dem automatisch anzupassen
- Windows DPI-Einstellungen des Benutzers, Verse
- Die DPI-Einstellung auf dem Computer des Entwicklers, der das Formular zuletzt gespeichert hat
Dies löst das Problem nicht, wenn der Benutzer eine andere Schriftart verwendet als die, mit der Sie das Formular entworfen haben, z.
- Der Entwickler hat das Formular mit MS Sans Serif 8pt entworfen (wobei das durchschnittliche Zeichen
6.21px x 13.00pxbei 96 dpi liegt).
Benutzer, der mit Tahoma 8pt läuft (wobei das durchschnittliche Zeichen 5.94px x 13.00pxbei 96 dpi liegt)
Wie bei jedem, der eine Anwendung für Windows 2000 oder Windows XP entwickelt.
oder
- Entwickler entwarf das Formular mit ** Tahoma 8pt * (wobei das durchschnittliche Zeichen
5.94px x 13.00pxbei 96 dpi liegt)
- ein Benutzer, der mit Segoe UI 9pt ausgeführt wird (wobei das durchschnittliche Zeichen
6.67px x 15pxbei 96 dpi liegt)
Als guter Entwickler werden Sie die Schriftarteneinstellungen Ihres Benutzers berücksichtigen. Dies bedeutet, dass Sie auch alle Steuerelemente in Ihrem Formular skalieren müssen, um sie an die neue Schriftgröße anzupassen:
- Erweitern Sie alles horizontal um 12,29% (6,67 / 5,94).
- Dehnen Sie alles vertikal um 15,38% (15/13)
Scaled Ich werde das nicht für dich erledigen.
Es wird schlimmer, wenn:
- hat Ihr Formular unter Segoe UI 9pt entworfen (Standardeinstellung für Windows Vista, Windows 7, Windows 8)
- Der Benutzer führt Segoe UI 14pt aus (z. B. meine Präferenz)
10.52px x 25px
Jetzt müssen Sie alles skalieren
- horizontal um 57,72%
- vertikal um 66,66%
Scaled Ich werde das nicht für dich erledigen.
Wenn Sie schlau sind, können Sie sehen, wie irrelevant es ist, DPI zu ehren:
- Formular mit Segoe UI 9pt @ 96dpi (6,67 x 15 Pixel)
- Benutzer, der mit Segoe UI 9pt @ 150dpi (10,52 x 25 Pixel) ausgeführt wird
Sie sollten nicht auf die DPI-Einstellung des Benutzers achten, sondern auf dessen Schriftgröße . Zwei Benutzer laufen
- Segoe UI 14pt @ 96dpi (10,52 x 25 Pixel)
- Segoe UI 9pt @ 150dpi (10,52 x 25 Pixel)
führen die gleiche Schriftart aus . DPI ist nur eine Sache, die die Schriftgröße beeinflusst. Die Vorlieben des Benutzers sind die anderen.
StandardizeFormFont
Clovis bemerkte, dass ich auf eine Funktion verweise StandardizeFormFont, die die Schriftart in einem Formular korrigiert und auf die neue Schriftgröße skaliert. Es ist keine Standardfunktion, sondern eine ganze Reihe von Funktionen, die die einfache Aufgabe erfüllen, die Borland nie erledigt hat.
function StandardizeFormFont(AForm: TForm): Real;
var
preferredFontName: string;
preferredFontHeight: Integer;
begin
GetUserFontPreference({out}preferredFontName, {out}preferredFontHeight);
//e.g. "Segoe UI",
Result := Toolkit.StandardizeFormFont(AForm, PreferredFontName, PreferredFontHeight);
end;
Windows hat 6 verschiedene Schriftarten; In Windows gibt es keine einzige "Schriftarteinstellung".
Wir wissen jedoch aus Erfahrung, dass unsere Formulare der Einstellung für die Symbolschriftart folgen sollten
procedure GetUserFontPreference(out FaceName: string; out PixelHeight: Integer);
var
font: TFont;
begin
font := Toolkit.GetIconTitleFont;
try
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
font.Free;
end;
end;
Sobald wir die Schriftgröße wissen , werden wir die Form skalieren zu , so erhalten wir die aktuelle Schrifthöhe des Formulars ( in Pixeln ) und skalieren um diesen Faktor auf.
Wenn ich beispielsweise das Formular auf -16setze und das Formular sich derzeit in befindet -11, müssen wir das gesamte Formular skalieren nach:
-16 / -11 = 1.45454%
Die Standardisierung erfolgt in zwei Phasen. Skalieren Sie das Formular zunächst nach dem Verhältnis der neuen zu den alten Schriftgrößen. Ändern Sie dann tatsächlich die Steuerelemente (rekursiv), um die neue Schriftart zu verwenden.
function StandardizeFormFont(AForm: TForm; FontName: string; FontHeight: Integer): Real;
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
Toolkit.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;
Hier ist die Aufgabe, ein Formular tatsächlich zu skalieren. Es umgeht Fehler in Borlands eigener Form.ScaleByMethode. Zuerst müssen alle Anker im Formular deaktiviert, dann die Skalierung durchgeführt und dann die Anker wieder aktiviert werden:
TAnchorsArray = array of TAnchors;
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;
und dann müssen wir rekursiv tatsächlich verwenden die neue Schriftart:
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 := Toolkit.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;
Wenn die Anker rekursiv deaktiviert sind:
function DisableAnchors(ParentControl: TWinControl): TAnchorsArray;
var
StartingIndex: Integer;
begin
StartingIndex := 0;
DisableAnchors_Core(ParentControl, Result, 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;
Und Anker werden rekursiv wieder aktiviert:
procedure EnableAnchors(ParentControl: TWinControl; aAnchorStorage: TAnchorsArray);
var
StartingIndex: Integer;
begin
StartingIndex := 0;
EnableAnchors_Core(ParentControl, aAnchorStorage, StartingIndex);
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;
Mit der Arbeit, eine Steuerelementschrift tatsächlich zu ändern, bleibt Folgendes übrig:
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;
Das ist viel mehr Code, als Sie gedacht haben. ich weiß. Das Traurige ist, dass es keinen Delphi-Entwickler auf der Welt gibt, außer mir, der seine Anwendungen tatsächlich korrekt macht.
Sehr geehrter Delphi-Entwickler, stellen Sie Ihre Windows-Schriftart auf Segoe UI 14pt ein und beheben Sie Ihre fehlerhafte Anwendung
Hinweis : Jeder Code wird öffentlich zugänglich gemacht. Keine Zuordnung erforderlich.
SetProcessDPIAware.