Penting juga untuk diperhatikan bahwa menghormati DPI pengguna hanyalah sebagian dari pekerjaan Anda yang sebenarnya:
menghormati ukuran font pengguna
Selama beberapa dekade, Windows telah memecahkan masalah ini dengan gagasan melakukan tata letak menggunakan Dialog Units , bukan piksel. Sebuah "unit dialog" didefinisikan sehingga karakter rata - rata font adalah
- 4 unit dialog (dlus) lebar, dan
- 8 unit dialog (clus) tinggi
Delphi memang dikirimkan dengan gagasan (buggy) Scaled, di mana formulir mencoba untuk menyesuaikan secara otomatis berdasarkan
- Pengaturan DPI Windows pengguna, ayat
- pengaturan DPI di mesin pengembang yang terakhir kali menyimpan formulir
Itu tidak menyelesaikan masalah ketika pengguna menggunakan font yang berbeda dari yang Anda desain formulir dengan, misalnya:
- pengembang merancang formulir dengan MS Sans Serif 8pt (di mana karakter rata-rata
6.21px x 13.00px, pada 96dpi)
pengguna menjalankan Tahoma 8pt (di mana karakter rata-rata 5.94px x 13.00px, pada 96dpi)
Seperti halnya dengan siapa pun yang mengembangkan aplikasi untuk Windows 2000 atau Windows XP.
atau
- pengembang merancang formulir dengan ** Tahoma 8pt * (di mana karakter rata-rata
5.94px x 13.00px, pada 96dpi)
- pengguna yang menjalankan dengan Segoe UI 9pt (di mana karakter rata-rata adalah
6.67px x 15px, pada 96dpi)
Sebagai pengembang yang baik, Anda akan menghormati preferensi font pengguna Anda. Ini berarti Anda juga perlu menskalakan semua kontrol pada formulir Anda agar sesuai dengan ukuran font baru:
- perluas semuanya secara horizontal sebesar 12,29% (6,67 / 5,94)
- regangkan semuanya secara vertikal sebesar 15,38% (15/13)
Scaled tidak akan menangani ini untuk Anda.
Ini menjadi lebih buruk ketika:
- mendesain formulir Anda di Segoe UI 9pt (Windows Vista, Windows 7, Windows 8 default)
- pengguna menjalankan Segoe UI 14pt , (misalnya preferensi saya) yang mana
10.52px x 25px
Sekarang Anda harus mengukur semuanya
- secara horizontal sebesar 57,72%
- secara vertikal sebesar 66,66%
Scaled tidak akan menangani ini untuk Anda.
Jika Anda pintar, Anda dapat melihat betapa menghormati DPI tidak relevan:
- formulir yang dirancang dengan Segoe UI 9pt @ 96dpi (6.67px x 15px)
- pengguna menjalankan dengan Segoe UI 9pt @ 150dpi (10.52px x 25px)
Anda tidak boleh melihat pengaturan DPI pengguna, Anda harus melihat ukuran fontnya . Dua pengguna berjalan
- Segoe UI 14pt @ 96pi (10.52px x 25px)
- Segoe UI 9pt @ 150dpi (10.52px x 25px)
menjalankan font yang sama . DPI hanyalah satu hal yang mempengaruhi ukuran font; preferensi pengguna adalah yang lain.
StandardizeFormFont
Clovis memperhatikan bahwa saya mereferensikan fungsi StandardizeFormFontyang memperbaiki font pada formulir, dan menskalakannya ke ukuran font baru. Ini bukan fungsi standar, tapi seluruh rangkaian fungsi yang menyelesaikan tugas sederhana yang tidak pernah ditangani Borland.
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 memiliki 6 font berbeda; tidak ada "pengaturan font" tunggal di Windows.
Tapi kita tahu dari pengalaman bahwa formulir kita harus mengikuti pengaturan Font Judul Ikon
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;
Setelah kita mengetahui ukuran font kita akan skala bentuk untuk , kita mendapatkan tinggi font saat form ( dalam pixel ), dan skala oleh faktor itu.
Misalnya, jika saya menyetel formulir ke -16, dan formulir saat ini di -11, maka kita perlu menskalakan seluruh formulir dengan:
-16 / -11 = 1.45454%
Standarisasi terjadi dalam dua tahap. Pertama, skala formulir dengan rasio ukuran font baru: lama. Kemudian ubah kontrol (secara rekursif) untuk menggunakan font baru.
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;
Inilah tugas untuk benar-benar menskalakan formulir. Ia bekerja di sekitar bug dalam Form.ScaleBymetode Borland sendiri . Pertama, ia harus menonaktifkan semua jangkar di formulir, lalu melakukan penskalaan, lalu mengaktifkan kembali jangkar:
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;
dan kemudian kita harus benar-benar menggunakan font baru secara rekursif :
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;
Dengan jangkar dinonaktifkan secara rekursif:
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;
Dan jangkar diaktifkan kembali secara rekursif:
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;
Dengan pekerjaan benar-benar mengubah font kontrol kiri menjadi:
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;
Itu jauh lebih banyak kode daripada yang Anda kira; aku tahu. Yang menyedihkan adalah tidak ada pengembang Delphi di dunia, kecuali saya, yang benar-benar membuat aplikasinya benar.
Pengembang Delphi yang terhormat : Setel font Windows Anda ke Segoe UI 14pt , dan perbaiki aplikasi buggy Anda
Catatan : Kode apa pun dilepaskan ke domain publik. Tidak diperlukan atribusi.
SetProcessDPIAware.