当Windows字体缩放大于100%时,如何使我的GUI表现良好

LaB*_*cca 105 windows delphi windows-7

在Windows控制面板中选择大字体大小(如125%或150%)时,每次按像素设置某些内容时,VCL应用程序中都会出现问题.

拿走TStatusBar.Panel.我已经设置了它的宽度,使它只包含一个标签,现在使用大字体标签"溢出".与其他组件相同的问题.

戴尔的一些新笔记本电脑已经默认设置为125%,因此在过去这个问题非常罕见,现在非常重要.

可以做些什么来克服这个问题?

Dav*_*nan 61

只要Scaled是.dfm文件中的设置将正确扩展True.

如果要在代码中设置尺寸,则需要将其Screen.PixelsPerInch除以Form.PixelsPerInch.使用MulDiv要做到这一点.

function TMyForm.ScaleDimension(const X: Integer): Integer;
begin
  Result := MulDiv(X, Screen.PixelsPerInch, PixelsPerInch);
end;
Run Code Online (Sandbox Code Playgroud)

这是当形式持久化框架所做ScaledTrue.

实际上,您可以使用一个为分母硬编码值96的版本来替换此函数.这允许您使用绝对维度值,如果您碰巧在开发计算机上更改字体缩放并重新保存.dfm文件,则不必担心意义更改.重要的是,PixelsPerInch存储在.dfm文件中的属性是上次保存.dfm文件的机器的值.

const
  SmallFontsPixelsPerInch = 96;

function ScaleFromSmallFontsDimension(const X: Integer): Integer;
begin
  Result := MulDiv(X, Screen.PixelsPerInch, SmallFontsPixelsPerInch);
end;
Run Code Online (Sandbox Code Playgroud)

因此,继续主题,另一件要警惕的事情是,如果你的项目是在具有不同DPI值的多台机器上开发的,你会发现Delphi在保存.dfm文件时使用的缩放导致控件在一系列编辑中徘徊.在我的工作地点,为了避免这种情况,我们有一个严格的政策,表格只能以96dpi编辑(100%缩放).

事实上,我的版本ScaleFromSmallFontsDimension也允许表单字体在运行时与设计时设置的不同.在XP机器上,我的应用程序的表单使用8pt Tahoma.在Vista和9pt上使用Segoe UI.这提供了另一个自由度.缩放必须考虑到这一点,因为假设源代码中使用的绝对尺寸值相对于96dpi的8pt Tahoma的基线.

如果您在UI中使用任何图像或字形,那么这些也需要扩展.一个常见的例子是工具栏和菜单上使用的字形.您需要将这些字形作为链接到可执行文件的图标资源提供.每个图标应包含一系列大小,然后在运行时选择最合适的大小并将其加载到图像列表中.有关该主题的一些详细信息,请参见此处:如何从资源加载图标而不会出现锯齿现象?

另一个有用的技巧是以相对单位定义维度,相对于TextWidthTextHeight.所以,如果你想要大约10条垂直线的东西,你可以使用10*Canvas.TextHeight('Ag').这是一个非常粗略和准备好的指标,因为它不允许行间距等.但是,通常您需要做的就是能够安排GUI正确缩放 PixelsPerInch.

您还应将应用程序标记为具有高DPI感知能力.执行此操作的最佳方法是通过应用程序清单.由于Delphi的构建工具不允许您自定义您使用的清单,因此强制您链接自己的清单资源.

<?xml version='1.0' encoding='UTF-8' standalone='yes'?>
<assembly xmlns="urn:schemas-microsoft-com:asm.v1" manifestVersion="1.0">
  <asmv3:application xmlns:asmv3="urn:schemas-microsoft-com:asm.v3">
    <asmv3:windowsSettings
         xmlns="http://schemas.microsoft.com/SMI/2005/WindowsSettings">
      <dpiAware>true</dpiAware>
    </asmv3:windowsSettings>
  </asmv3:application>
</assembly>
Run Code Online (Sandbox Code Playgroud)

资源脚本如下所示:

1 24 "Manifest.txt"
Run Code Online (Sandbox Code Playgroud)

其中Manifest.txt包含实际清单.您还需要包含comctl32 v6部分并设置requestedExecutionLevelasInvoker.然后,您将此编译的资源链接到您的应用程序,并确保Delphi不会尝试对其清单执行相同操作.在现代Delphi中,您可以通过将Runtime Themes项目选项设置为None来实现.

清单是声明您的应用程序具有高DPI感知能力的正确方法.如果您只想快速尝试而不弄乱您的清单,请致电SetProcessDPIAware.这样做是应用程序运行时的第一件事.最好是在早期单元初始化部分之一中,或者作为.dpr文件中的第一个部分.

如果您没有声明您的应用程序具有高DPI感知能力,则Vista和更高版本将使其处于传统模式,以便任何字体缩放超过125%.这看起来非常可怕.尽量避免陷入陷阱.

Windows 8.1每个监视器DPI更新

作为Windows 8.1中的,现在有每监视器DPI设置操作系统支持(http://msdn.microsoft.com/en-ca/magazine/dn574798.aspx).对于可能具有不同显示器的现代设备来说,这是一个很大的问题.您可能拥有非常高的DPI笔记本电脑屏幕和低DPI外部投影仪.支持这种情况需要比上述更多的工作.

  • @WarrenP 那又怎样?完全有可能使用 Delphi 构建比 Delphi IDE 表现更好的应用程序。 (3认同)
  • 这并非总是如此.事实上,设置Scaled = true,然后设置高DPI感知也可能导致大多数delphi应用程序中的一些奇怪的破坏.我已经花了数百个小时试图让我的应用程序在高DPI下工作,并且发现在控件裁剪,屏幕移动,各种控件上的额外或丢失滚动条等方面看起来更糟糕的像素更好. (2认同)
  • 好东西.+1获取精彩信息.我的意见(不要这样做)对于需要知道如何做到这一点至关重要... (2认同)
  • 我认为目前(我正在使用 10.1 Berlin Update 2),您需要使用“Monitor.PixelsPerInch”而不是“Screen.PixelsPerInch”,以支持具有不同分辨率的多个屏幕的系统。无论程序位于哪个显示器上,“Screen.ppi”都将始终返回相同的值。 (2认同)

War*_* P 53

注意:请参阅其他答案,因为它们包含非常有价值的技巧.我在这里的回答只提供了警告和警告,不要假设DPI意识很容易.

我通常避免使用DPI感知扩展TForm.Scaled = True.DPI意识对我来说非常重要,因为对于打电话给我并愿意为此付费的客户来说,这一点很重要.这种观点背后的技术原因是DPI意识与否,你正在打开一扇窗户进入一个受伤的世界.许多标准和第三方VCL控件在高DPI中不能很好地工作.包含Windows公共控件的VCL部件在高DPI下工作得非常好.大量的第三方和内置Delphi VCL自定义控件在高DPI下无法正常工作,或根本无法工作.如果您打算打开TForm.Scaled,请确保为项目中的每个表单以及您使用的每个第三方和内置控件测试96,125和150 DPI.

Delphi本身就是用Delphi编写的.对于大多数表单,它都打开了高DPI感知标志,尽管最近在Delphi XE2中,IDE作者自己决定不打开高DPI感知清单标志.请注意,在Delphi XE4及更高版本中,HIGH DPI感知标志已打开,IDE看起来很好.

我建议你不要使用TForm.Scaled = true(这是Delphi中的默认值,所以除非你已经修改了它,大多数表单都有Scaled = true)和高DPI Aware标志(如David的答案中所示)使用内置delphi表单设计器构建的VCL应用程序.

我曾经尝试过制作一个最小的样本,当TForm.Scaled为真时,你可以期待看到的那种破损,以及当Delphi形式缩放时有一个小故障.这些故障并不总是仅由96以外的DPI值触发.我无法确定其他内容的完整列表,包括Windows XP字体大小更改.但由于大多数这些故障只出现在我自己的应用程序中,在相当复杂的情况下,我已经决定向您展示一些可以验证自己的证据.

当您在Windows 7中将DPI Scaling设置为"Fonts @ 200%"时,Delphi XE看起来像这样,并且在Windows 7和8上类似地破坏了Delphi XE2,但是这些故障在Delphi XE4中似乎是固定的:

在此输入图像描述

在此输入图像描述

这些主要是标准VCL控制,在高DPI下行为不端.请注意,大多数事情都没有扩展,因此Delphi IDE开发人员决定忽略DPI感知,并关闭DPI虚拟化.这样一个有趣的选择.

只有在想要这种新的额外痛苦来源和困难的选择时,才能关闭DPI虚拟化.我建议你不要管它.请注意,Windows常用控件似乎工作正常.请注意,Delphi数据资源管理器控件是围绕标准Windows树公共控件的C#WinForms包装器.这是一个纯粹的微软故障,修复它可能要求Embarcadero为其数据资源管理器重写纯粹的原生.Net树控件,或者编写一些DPI检查和修改属性代码来更改控件中的项高度.甚至微软WinForms也无法自动处理高DPI,也无需自定义kludge代码.

更新:有趣的事实:虽然delphi IDE似乎不是"虚拟化",但它没有使用David显示的清单内容来实现"非DPI虚拟化".也许它在运行时使用了一些API函数.

更新2:为了回应我如何支持100%/ 125%DPI,我会提出一个两阶段计划.阶段1是清点我的代码以获取需要针对高DPI修复的自定义控件,然后制定计划来修复它们或逐步淘汰它们.第2阶段是将我的代码的某些区域设计为没有布局管理的表单,并将它们更改为使用某种布局管理的表单,以便DPI或字体高度更改可以在不剪切的情况下工作.我怀疑这种"互控"布局工作在大多数应用中比"内部控制"工作要复杂得多.

更新: 2016年,最新的Delphi 10.1 Berlin在我的150 dpi工作站上运行良好.

  • RAD Studio是标准VCL控件,自定义控件,.NET WinForms和FireMonkey表单的重要组合.有问题并不奇怪.这就是为什么RAD Studio不是一个很好的例子. (6认同)
  • 该API函数将是[`SetProcessDPIAware`](http://msdn.microsoft.com/en-us/library/ms633543.aspx). (5认同)
  • 优秀.谢谢你的新事实.我建议你修改你的答案,建议作为一种可能的途径.可能客户甚至可能想要配置该选项(如果它不起作用则关闭它). (2认同)

Ian*_*oyd 41

值得注意的是,尊重用户的DPI只是您实际工作的一部分:

尊重用户的字体大小

几十年来,Windows已经使用对话单元而不是像素执行布局的概念解决了这个问题.一个"对话框单位"如此定义字体的平均字符

  • 4个对话框单元(dlus)宽,和
  • 8个对话框单元(clus)高

在此输入图像描述

Delphi确实附带了一个(错误的)概念Scaled,表单试图根据其自动调整

  • 用户的Windows DPI设置,经文
  • 上次保存表单的开发人员的计算机上的DPI设置

当用户使用与您设计表单不同的字体时,这并不能解决问题,例如:

  • 开发人员使用MS Sans Serif 8pt设计了表单(平均字符为6.21px x 13.00px96dpi)
  • 用户运行Tahoma 8pt(平均字符为5.94px x 13.00px96dpi)

    与开发Windows 2000或Windows XP应用程序的任何人一样.

要么

  • 开发人员使用**Tahoma 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设计您的表单(Windows Vista,Windows 7,Windows 8默认)
  • 用户正在运行Segoe UI 14pt,(例如我的偏好)10.52px x 25px

现在你必须扩展一切

  • 水平方向57.72%
  • 垂直方向66.66%

Scaled 不会为你处理这件事.


如果你很聪明,你可以看到DPI是多么的无可挑剔:

  • 使用Segoe UI设计的表格9pt @ 96dpi(6.67px x 15px)
  • 用户运行Segoe UI 9pt @ 150dpi(10.52px x 25px)

你不应该看用户的DPI设置,你应该看看他们的字体大小.两个用户正在运行

  • Segoe UI 14pt @ 96dpi(10.52px x 25px)
  • Segoe UI 9pt @ 150dpi(10.52px x 25px)

正在运行相同的字体.DPI只是影响字体大小的件事; 用户的偏好是另一个.

StandardizeFormFont

克洛维斯注意到我引用了一个StandardizeFormFont修复表单上字体的函数,并将其缩放到新的字体大小.它不是一个标准函数,而是一整套函数,它们完成了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;
Run Code Online (Sandbox Code Playgroud)

Windows有6种不同的字体; Windows中没有单一的"字体设置".
但是我们从经验中知道我们的表单应该遵循Icon Title Font设置

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;
Run Code Online (Sandbox Code Playgroud)

一旦我们知道了字体大小,我们将缩放表格,我们得到了窗体的当前字体高度(以像素为单位),以及由这个因素扩大.

例如,如果我将表单设置为-16,表单当前处于-11,那么我们需要通过以下方式缩放整个表单:

-16 / -11 = 1.45454%
Run Code Online (Sandbox Code Playgroud)

标准化分两个阶段进行.首先按新旧字体大小的比例缩放表单.然后实际更改控件(递归)以使用新字体.

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;
Run Code Online (Sandbox Code Playgroud)

这是实际缩放表单的工作.它适用于Borland自己的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;
Run Code Online (Sandbox Code Playgroud)

然后我们必须以递归方式实际使用新字体:

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;
Run Code Online (Sandbox Code Playgroud)

随着锚被递归禁用:

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;
Run Code Online (Sandbox Code Playgroud)

并且递归地重新启用锚点:

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;
Run Code Online (Sandbox Code Playgroud)

将实际更改控件字体的工作留给:

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;
Run Code Online (Sandbox Code Playgroud)

这比你想象的要多得多; 我知道.令人遗憾的是,除了我之外,世界上没有Delphi开发人员,他们实际上使他们的应用程序正确.

亲爱的Delphi开发人员:将您的Windows字体设置为Segoe UI 14pt,并修复您的错误应用程序

注意:任何代码都将发布到公共域中.无需归属.

  • "令人遗憾的是,除了我之外,世界上没有Delphi开发人员,他们实际上使他们的应用程序正确无误." 这是一个非常傲慢的陈述是不正确的.从我的回答:*实际上,我的ScaleFromSmallFontsDimension版本也允许表单字体在运行时与设计时的设置字体不同.缩放必须考虑到这一点,因为源代码中使用的绝对尺寸值假定相对于96dpi时8pt Tahoma的基线.*对于您来说,这是一个很好的答案,+ 1. (3认同)
  • 伊恩,这真是太棒了.谢谢. (2认同)
  • 最近碰到了这个问题和答案.我已经将所有Ian的代码收集到了一个工作单元:http://pastebin.com/dKpfnXLc并在Google+上发布了它:https://goo.gl/0ARdq9如果有人认为这有用,请在此处发布. (2认同)

avr*_*vra 11

这是我的礼物.一个可以帮助您在GUI布局中水平定位元素的函数.所有人都免费.

function CenterInParent(Place,NumberOfPlaces,ObjectWidth,ParentWidth,CropPercent: Integer): Integer;
  {returns formated centered position of an object relative to parent.
  Place          - P order number of an object beeing centered
  NumberOfPlaces - NOP total number of places available for object beeing centered
  ObjectWidth    - OW width of an object beeing centered
  ParentWidth    - PW width of an parent
  CropPercent    - CP percentage of safe margin on both sides which we want to omit from calculation
  +-----------------------------------------------------+
  |                                                     |
  |        +--------+       +---+      +--------+       |
  |        |        |       |   |      |        |       |
  |        +--------+       +---+      +--------+       |
  |     |              |             |            |     |
  +-----------------------------------------------------+
  |     |<---------------------A----------------->|     |
  |<-C->|<------B----->|<-----B----->|<-----B---->|<-C->|
  |                    |<-D>|
  |<----------E------------>|

  A = PW-C   B = A/NOP  C=(CP*PW)/100  D = (B-OW)/2
  E = C+(P-1)*B+D }

var
  A, B, C, D: Integer;
begin
  C := Trunc((CropPercent*ParentWidth)/100);
  A := ParentWidth - C;
  B := Trunc(A/NumberOfPlaces);
  D := Trunc((B-ObjectWidth)/2);
  Result := C+(Place-1)*B+D;
end;
Run Code Online (Sandbox Code Playgroud)

  • 我很高兴你喜欢沃伦.大约有15年的时间,因为我不得不解决这个问题的解决方案.即使在今天,也可能存在可以应用的情况.B-) (2认同)