È anche importante notare che onorare il DPI dell'utente è solo un sottoinsieme del tuo vero lavoro:
onorare la dimensione del carattere dell'utente
Per decenni, Windows ha risolto questo problema con l'idea di eseguire il layout utilizzando le unità di dialogo , anziché i pixel. Una "unità di dialogo" è definita in modo che il carattere medio del font sia
- 4 unità di dialogo (dlus) di larghezza e
- 8 unità di dialogo (clus) di altezza
Delphi viene fornito con una nozione (buggy) di Scaled, in cui un modulo cerca di adattarsi automaticamente in base a
- Impostazioni DPI di Windows dell'utente, versi
- l'impostazione DPI sulla macchina dello sviluppatore che ha salvato per ultimo il modulo
Ciò non risolve il problema quando l'utente utilizza un carattere diverso da quello con cui hai progettato il modulo, ad esempio:
- lo sviluppatore ha progettato il modulo con MS Sans Serif 8pt (dove il carattere medio è
6.21px x 13.00px, a 96 dpi)
utente che esegue con Tahoma 8pt (dove il carattere medio è 5.94px x 13.00px, a 96 dpi)
Come nel caso di chiunque sviluppasse un'applicazione per Windows 2000 o Windows XP.
o
- lo sviluppatore ha progettato il modulo con ** Tahoma 8pt * (dove il carattere medio è
5.94px x 13.00px, a 96 dpi)
- un utente che esegue con Segoe UI 9pt (dove il carattere medio è
6.67px x 15px, a 96 dpi)
Come buon sviluppatore, onorerai le preferenze dei caratteri dei tuoi utenti. Ciò significa che devi anche ridimensionare tutti i controlli sul modulo in modo che corrispondano alla nuova dimensione del carattere:
- espande tutto in orizzontale del 12,29% (6,67 / 5,94)
- allunga tutto verticalmente del 15,38% (15/13)
Scaled non gestirà questo per te.
Peggio quando:
- ha progettato il modulo su Segoe UI 9pt (Windows Vista, Windows 7, Windows 8 predefinito)
- l'utente esegue Segoe UI 14pt , (ad esempio la mia preferenza) che è
10.52px x 25px
Ora devi ridimensionare tutto
- orizzontalmente del 57,72%
- verticalmente del 66,66%
Scaled non gestirà questo per te.
Se sei intelligente, puoi vedere quanto sia irrelavante onorare DPI:
- modulo progettato con Segoe UI 9pt @ 96dpi (6.67px x 15px)
- utente che esegue con Segoe UI 9pt a 150 dpi (10,52 px x 25 px)
Non dovresti guardare l'impostazione DPI dell'utente, dovresti guardare la dimensione del carattere . Due utenti in esecuzione
- Interfaccia utente Segoe 14 pt a 96 dpi (10,52 px x 25 px)
- Interfaccia utente Segoe 9 pt a 150 dpi (10,52 px x 25 px)
eseguono lo stesso tipo di carattere . DPI è solo una cosa che influisce sulla dimensione del carattere; le preferenze dell'utente sono le altre.
StandardizeFormFont
Clovis ha notato che faccio riferimento a una funzione StandardizeFormFontche corregge il carattere su un modulo e lo ridimensiona alla nuova dimensione del carattere. Non è una funzione standard, ma un intero set di funzioni che svolgono il compito semplice che Borland non ha mai gestito.
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 ha 6 diversi tipi di carattere; non esiste una singola "impostazione dei caratteri" in Windows.
Ma sappiamo per esperienza che i nostri moduli dovrebbero seguire l' impostazione Carattere titolo icona
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;
Una volta che sappiamo che la dimensione del carattere ci sarà scalare il modulo a , otteniamo altezza carattere corrente del form ( in pixel ), e la scala da tale fattore.
Ad esempio, se sto impostando il modulo su -16e il modulo è attualmente in -11, allora dobbiamo ridimensionare l'intero modulo:
-16 / -11 = 1.45454%
La standardizzazione avviene in due fasi. Per prima cosa ridimensiona il modulo in base al rapporto tra le dimensioni del carattere nuovo e vecchio. Quindi modificare effettivamente i controlli (in modo ricorsivo) per utilizzare il nuovo carattere.
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;
Ecco il compito di ridimensionare effettivamente un modulo. Funziona attorno ai bug nel Form.ScaleBymetodo di Borland . Per prima cosa deve disabilitare tutti gli ancoraggi sul modulo, quindi eseguire il ridimensionamento, quindi riattivare gli ancoraggi:
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;
e allora dobbiamo ricorsivamente in realtà usare il nuovo font:
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;
Con le ancore disabilitate in modo ricorsivo:
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;
E le ancore vengono riattivate ricorsivamente:
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;
Con il lavoro di cambiare effettivamente un carattere dei controlli lasciato a:
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;
È molto più codice di quanto pensavi che sarebbe stato; lo so. La cosa triste è che non c'è nessuno sviluppatore Delphi al mondo, tranne me, che effettivamente rende corrette le proprie applicazioni.
Caro sviluppatore Delphi : imposta il tuo carattere Windows su Segoe UI 14pt e correggi la tua applicazione difettosa
Nota : qualsiasi codice viene rilasciato nel pubblico dominio. Nessuna attribuzione richiesta.
SetProcessDPIAware.