Cũng cần lưu ý rằng việc tôn vinh DPI của người dùng chỉ là một phần nhỏ trong công việc thực sự của bạn:
tôn trọng kích thước phông chữ của người dùng
Trong nhiều thập kỷ, Windows đã giải quyết vấn đề này với khái niệm thực hiện bố cục bằng các Đơn vị hộp thoại , thay vì pixel. Một "đơn vị thoại" được định nghĩa như vậy của phông chữ mà nhân vật trung bình là
- 4 đơn vị hộp thoại (dlus) rộng và
- 8 đơn vị hộp thoại (nhóm) cao
Delphi đưa ra khái niệm (lỗi) Scaled, trong đó biểu mẫu cố gắng tự động điều chỉnh dựa trên
- Cài đặt Windows DPI của người dùng, câu
- cài đặt DPI trên máy của nhà phát triển đã lưu biểu mẫu lần cuối
Điều đó không giải quyết được vấn đề khi người dùng sử dụng phông chữ khác với phông chữ bạn đã thiết kế biểu mẫu, ví dụ:
hoặc là
- nhà phát triển đã thiết kế biểu mẫu với ** Tahoma 8pt * (trong đó ký tự trung bình là
5.94px x 13.00px96dpi)
- một người dùng chạy với Segoe UI 9pt (trong đó ký tự trung bình là
6.67px x 15px96dpi)
Là một nhà phát triển giỏi, bạn sẽ tôn trọng sở thích phông chữ của người dùng. Điều này có nghĩa là bạn cũng cần mở rộng tất cả các điều khiển trên biểu mẫu của mình để phù hợp với kích thước phông chữ mới:
- mở rộng mọi thứ theo chiều ngang 12,29% (6,67 / 5,94)
- kéo dài mọi thứ theo chiều dọc 15,38% (15/13)
Scaled sẽ không giải quyết việc này cho bạn.
Nó trở nên tồi tệ hơn khi:
- đã thiết kế biểu mẫu của bạn tại Segoe UI 9pt (mặc định Windows Vista, Windows 7, Windows 8)
- người dùng đang chạy Segoe UI 14pt , (ví dụ: sở thích của tôi) là
10.52px x 25px
Bây giờ bạn phải mở rộng mọi thứ
- theo chiều ngang là 57,72%
- theo chiều dọc là 66,66%
Scaled sẽ không giải quyết việc này cho bạn.
Nếu bạn thông minh, bạn có thể thấy việc tôn vinh DPI là không cần thiết:
- biểu mẫu được thiết kế với Segoe UI 9pt @ 96dpi (6.67px x 15px)
- người dùng chạy với Segoe UI 9pt @ 150dpi (10,52px x 25px)
Bạn không nên xem cài đặt DPI của người dùng, bạn nên xem kích thước phông chữ của họ . Hai người dùng đang chạy
- Segoe UI 14pt @ 96dpi (10,52px x 25px)
- Segoe UI 9pt @ 150dpi (10,52px x 25px)
đang chạy cùng một phông chữ . DPI chỉ là một thứ ảnh hưởng đến kích thước phông chữ; sở thích của người dùng là khác.
StandardizeFormFont
Clovis nhận thấy rằng tôi tham chiếu một hàm StandardizeFormFontsửa phông chữ trên một biểu mẫu và chia tỷ lệ nó thành kích thước phông chữ mới. Nó không phải là một hàm tiêu chuẩn, mà là một tập hợp các hàm hoàn thành nhiệm vụ đơn giản mà Borland chưa bao giờ xử lý.
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 có 6 phông chữ khác nhau; không có "cài đặt phông chữ" duy nhất trong Windows.
Nhưng chúng tôi biết từ kinh nghiệm rằng các biểu mẫu của chúng tôi phải tuân theo cài đặt Phông chữ Tiêu đề Biểu tượng
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;
Một khi chúng ta biết kích thước phông chữ, chúng tôi sẽ mở rộng các hình thức cho , chúng tôi nhận chiều cao font chữ hiện tại của hình thức ( bằng pixel ), và mở rộng quy mô của yếu tố đó.
Ví dụ: nếu tôi đang đặt biểu mẫu thành -16và biểu mẫu hiện đang ở -11, thì chúng tôi cần chia tỷ lệ toàn bộ biểu mẫu bằng:
-16 / -11 = 1.45454%
Quá trình tiêu chuẩn hóa xảy ra trong hai giai đoạn. Trước tiên hãy chia tỷ lệ biểu mẫu theo tỷ lệ của kích thước phông chữ mới: cũ. Sau đó thực sự thay đổi các điều khiển (đệ quy) để sử dụng phông chữ mới.
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;
Đây là công việc thực sự mở rộng một biểu mẫu. Nó hoạt động xung quanh các lỗi theo Form.ScaleByphương pháp riêng của Borland . Đầu tiên nó phải vô hiệu hóa tất cả các neo trên biểu mẫu, sau đó thực hiện điều chỉnh tỷ lệ, sau đó bật lại các neo:
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;
và sau đó chúng ta phải đệ quy thực sự sử dụng phông chữ mới:
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;
Với các neo bị vô hiệu hóa đệ quy:
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;
Và neo đang được bật lại đệ quy:
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;
Với công việc thực sự thay đổi phông chữ điều khiển sang trái:
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;
Đó là rất nhiều mã hơn bạn nghĩ; tôi biết. Điều đáng buồn là không có nhà phát triển Delphi nào trên trái đất, ngoại trừ tôi, người thực sự làm cho các ứng dụng của họ chính xác.
Kính gửi nhà phát triển Delphi : Đặt phông chữ Windows của bạn thành Segoe UI 14pt và sửa ứng dụng lỗi của bạn
Lưu ý : Bất kỳ mã nào được phát hành vào miền công cộng. Không cần ghi công.
SetProcessDPIAware.