यह भी ध्यान रखना महत्वपूर्ण है कि उपयोगकर्ता की DPI को सम्मानित करना आपकी वास्तविक नौकरी का केवल एक सबसेट है:
उपयोगकर्ता के फ़ॉन्ट आकार का सम्मान करना
दशकों तक, विंडोज ने इस मुद्दे को पिक्सल के बजाय डायलॉग इकाइयों का उपयोग करते हुए धारणा प्रदर्शन के साथ हल किया है । एक "संवाद इकाई" को परिभाषित किया गया है ताकि फ़ॉन्ट का औसत चरित्र हो
- 4 संवाद इकाइयाँ (dlus) चौड़ी, और
- 8 संवाद इकाइयाँ (क्लस) ऊँची
डेल्फी एक (छोटी गाड़ी) धारणा के साथ जहाज करता है Scaled, जहां एक रूप के आधार पर स्वचालित रूप से समायोजित करने की कोशिश करता है
- उपयोगकर्ता की विंडोज डीपीआई सेटिंग्स, छंद
- डेवलपर की मशीन पर डीपीआई सेटिंग जो अंतिम रूप से फॉर्म को बचाता है
जब उपयोगकर्ता आपके द्वारा डिज़ाइन किए गए फ़ॉर्म से भिन्न किसी फ़ॉन्ट का उपयोग करता है, तो यह समस्या हल नहीं करता है, जैसे:
या
- डेवलपर ने ** तहोमा 8pt * के साथ फॉर्म तैयार किया (जहाँ औसत चरित्र
5.94px x 13.00px96dpi पर है)
- Segoe UI 9pt के साथ चलने वाला उपयोगकर्ता (जहां औसत चरित्र
6.67px x 15px96dpi पर है)
एक अच्छे डेवलपर के रूप में आप अपने उपयोगकर्ता की प्राथमिकताओं का सम्मान करने जा रहे हैं। इसका मतलब है कि आपको नए फॉण्ट के आकार से मेल खाने के लिए अपने फॉर्म पर सभी नियंत्रणों को पैमाना करना होगा:
- 12.29% (6.67 / 5.94) द्वारा क्षैतिज रूप से सब कुछ का विस्तार करें
- 15.38% (15/13) तक सब कुछ लंबवत रूप से फैलाएं
Scaled यह आपके लिए नहीं होगा।
यह बदतर हो जाता है जब:
- Segoe UI 9pt (विंडोज विस्टा, विंडोज 7, विंडोज 8 डिफॉल्ट) में अपना फॉर्म डिजाइन किया
- उपयोगकर्ता Segoe UI 14pt चला रहा है , (जैसे मेरी प्राथमिकता) जो है
10.52px x 25px
अब आपको हर चीज को स्केल करना होगा
- क्षैतिज रूप से 57.72%
- 66.66% द्वारा लंबवत
Scaled यह आपके लिए नहीं होगा।
यदि आप होशियार हैं तो आप देख सकते हैं कि डीपीआई का सम्मान करना कितना अनुचित है:
- Segoe UI 9pt @ 96dpi (6.67px x 15px) के साथ तैयार किया गया फॉर्म
- Segoe UI 9pt @ 150dpi (10.52px x 25px) के साथ चलने वाला उपयोगकर्ता
आपको उपयोगकर्ता की डीपीआई सेटिंग नहीं देखनी चाहिए, आपको उनके फ़ॉन्ट आकार को देखना चाहिए । दो उपयोगकर्ता चल रहे हैं
- Segoe UI 14pt @ 96dpi (10.52px x 25px)
- Segoe UI 9pt @ 150dpi (10.52px x 25px)
एक ही फ़ॉन्ट चला रहे हैं । डीपीआई केवल एक चीज है जो फ़ॉन्ट आकार को प्रभावित करती है; उपयोगकर्ता की प्राथमिकताएँ अन्य हैं।
StandardizeFormFont
क्लोविस ने देखा कि मैं एक फ़ंक्शन को संदर्भित करता हूं StandardizeFormFontजो फ़ॉन्ट को एक फॉर्म पर ठीक करता है, और इसे नए फ़ॉन्ट आकार में स्केल करता है। यह एक मानक कार्य नहीं है, बल्कि उन कार्यों का एक पूरा समूह है जो सरल कार्य को पूरा करता है जिसे बोरलैंड ने कभी संभाला नहीं था।
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;
विंडोज में 6 अलग-अलग फोंट हैं; विंडोज में एक भी "फॉन्ट सेटिंग" नहीं है।
लेकिन हम अनुभव से जानते हैं कि हमारे रूपों को आइकन शीर्षक फ़ॉन्ट सेटिंग का पालन करना चाहिए
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;
एक बार जब हम फ़ॉन्ट आकार को जान लेते हैं , तो हम फ़ॉर्म को स्केल कर देंगे , हमें फॉर्म की वर्तमान फ़ॉन्ट ऊँचाई ( पिक्सेल में ) मिल जाएगी, और उस कारक द्वारा स्केल कर दी जाएगी।
उदाहरण के लिए, यदि मैं -16वर्तमान में फॉर्म सेट कर रहा हूं , और फॉर्म वर्तमान में है -11, तो हमें पूरे फॉर्म को निम्नानुसार स्केल करना होगा:
-16 / -11 = 1.45454%
मानकीकरण दो चरणों में होता है। पहले फॉर्म को नए: पुराने फॉन्ट साइज के अनुपात से स्केल करें। फिर नए फ़ॉन्ट का उपयोग करने के लिए वास्तव में नियंत्रण (पुनरावर्ती) बदलें।
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;
यहाँ वास्तव में एक फार्म स्केलिंग का काम है। यह बोरलैंड की अपनी Form.ScaleByविधि में बग के आसपास काम करता है । पहले इसे फॉर्म पर सभी एंकर को निष्क्रिय करना होगा, फिर स्केलिंग प्रदर्शन करना होगा, फिर एंकर को फिर से सक्षम करना होगा:
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;
और फिर हमें नए फ़ॉन्ट का पुनरावर्ती उपयोग करना होगा:
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;
एंकरों को पुन: अक्षम किया जा रहा है:
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;
और लंगर फिर से सक्षम किया जा रहा है:
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;
वास्तव में एक नियंत्रण फ़ॉन्ट बदलने के काम के साथ छोड़ दिया:
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;
यह एक बहुत अधिक कोड है जितना आपने सोचा था कि यह होने जा रहा था; मुझे पता है। दुःख की बात यह है कि पृथ्वी पर कोई डेल्फी डेवलपर नहीं है, मेरे अलावा, जो वास्तव में अपने अनुप्रयोगों को सही बनाता है।
प्रिय डेल्फी डेवलपर : Segoe UI 14pt के लिए अपना विंडोज फ़ॉन्ट सेट करें , और अपने छोटी गाड़ी के आवेदन को ठीक करें
नोट : कोई भी कोड सार्वजनिक डोमेन में जारी किया जाता है। कोई एट्रिब्यूशन की आवश्यकता नहीं है।
SetProcessDPIAware।