当表单大小改变时标签字体的调整

Question

我试图让表单调整大小时，该表单上的标签也会相应地调整大小。值得一提的是，只有在触发“WMExitSizeMove”过程时才会发生调整大小。编辑：我更喜欢比例方法，它不会超出或低于约束的大小。

理想情况下，我希望能够获得某种基于表单增大或缩小程度的“比例”值。然后，我可以将此比例因子应用于表单/面板上的所有控件。

但是，我会接受标签字体大小将调整为标签高度属性的最大可能大小（我会使用宽度，但该值似乎永远不会改变，因为标题是静态的）。

我有一个标签，将其放置到表单上，并给它所有锚定（左、右、顶部和底部都为真）。设置约束条件，以使控件看起来不会太小或太大。我希望标签文本大小尽可能大，同时保持控件的高度和宽度边界。当控件高度现在低于文本高度时，我不希望发生剪切，在这一点上，我希望标签文本的调整大小能够在新的控件高度下达到最大的大小。

示例 label.font.size：= 11; Label.Height：= 15;

表单调整大小，因此label.height为12

理论上，下一个最佳的label.font.size将是9，因为这里没有剪切。

如果您需要更多的描述或更好的澄清，请告诉我。最近这对我来说一直是个大问题。

TLDR：希望计算出表单调整大小的比例，以便我可以将其应用于所有控件，否则一种动态调整标签字体大小以适应调整大小的新高度/宽度的方法。

另外：我尝试过Calculate Max Font size，但可能我使用方式有误，当我调整表单大小时，宽度保持不变，因为它似乎与textwidth相关联。

编辑：实际上，我认为比例方法最好，只是不知道该如何做到这一点。我的数学能力有些生疏！还必须符合约束条件。

- Eddy

---

你为什么要将所有锚点设置为true？这会破坏任何你尝试实现的缩放系统。 - Nasreddine Galfout

我猜想控件会随着窗体大小的改变而自动“拉伸”，从而省去我手动处理一切的必要性。不过我认为事实并非如此。 - Eddy

你可以查看TForm.ScaleBy() / ScaleForPPI()，并使用按钮进行缩放，而不是可调整大小的边框，也许你会喜欢结果。 - Atys

Answer 1

仅在顶部和左侧使用锚点。然后在WMExitSizeMove消息过程中使用以下代码：Label1.Height := (Label1.Height * Height) div OldHeight;，并将Width用作缩放系统。然后使用David的答案来使用缩放更新字体（使用OPs评论中的pasteBin函数）。这对于简单的缩放系统非常有效。如果只更改宽度或高度时字体不进行缩放会影响您，则可以在该情况下停止标签的缩放。

以下代码翻译成我所说的话。

unit Unit12;

interface

uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
  Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, system.Math;

type
  TForm12 = class(TForm)
    Label1: TLabel;
    procedure FormCreate(Sender: TObject);
  private
    { Private declarations }
    procedure WMExitSizeMove(var aMessage: TMessage); message WM_ExitSizeMove;
  public
    { Public declarations }

  end;

var
  Form12: TForm12;
  OldWidth, OldHeight: Integer;
implementation

{$R *.dfm}

{ TForm12 }

function CalculateMazSize(aCanvas: TCanvas; aText: string; aWidth, aHeight: Integer): Integer;

  function LargestFontSizeToFitWidth(aCanvas: TCanvas; aText: string; aWidth: Integer): Integer;
  var
    Font: TFont;
    FontRecall: TFontRecall;
    InitialTextWidth: Integer;
  begin
    Font := aCanvas.Font;
    Result := Font.Size;
    FontRecall := TFontRecall.Create(Font);
    try
      InitialTextWidth := aCanvas.TextWidth(aText);
      Font.Size := MulDiv(Font.Size, aWidth, InitialTextWidth);

      if InitialTextWidth < aWidth then
        while True do
        begin
          Font.Size := Font.Size + 1;
          if aCanvas.TextWidth(aText) > aWidth then
            exit(Font.Size - 1);
        end;

      if InitialTextWidth > aWidth then
      begin
        while True do
        begin
          Font.Size := Font.Size - 1;
        if aCanvas.TextWidth(aText) <= aWidth then
          exit(Font.Size);
        end;
      end;
    finally
      FontRecall.Free;
    end;
  end;

  function LargestFontSizeToFitHeight(aCanvas: TCanvas; aText: string; aHeight: Integer): Integer;
  var
    Font: TFont;
    FontRecall: TFontRecall;
    InitialTextHeight: Integer;
  begin
    Font := aCanvas.Font;
    Result := Font.Size;
    FontRecall := TFontRecall.Create(Font);
    try
      InitialTextHeight := aCanvas.TextHeight(aText);
      Font.Size := MulDiv(Font.Size, aHeight, InitialTextHeight);

      if InitialTextHeight < aHeight then
        while True do
        begin
          Font.Size := Font.Size + 1;
          if aCanvas.TextHeight(aText) > aHeight then
            exit(Font.Size - 1);
        end;

      if InitialTextHeight > aHeight then
        while True do
        begin
          Font.Size := Font.Size - 1;
          if aCanvas.TextHeight(aText) <= aHeight then
            exit(Font.Size);
        end;

    finally
      FontRecall.Free;
    end;
  end;

begin
  if aText <> '' then
    Result := Min(LargestFontSizeToFitWidth(aCanvas, aText, aWidth),
                  LargestFontSizeToFitHeight(aCanvas, aText, aHeight))
  else
    Result := aCanvas.Font.Size;
end;

procedure TForm12.FormCreate(Sender: TObject);
begin
   OldWidth := Width;
   OldHeight := Height;
end;

procedure TForm12.WMExitSizeMove(var aMessage: TMessage);
begin
  // scaling
  Label1.Height := (Label1.Height * Height) div OldHeight;
  Label1.Width := (Label1.Width * Width) div OldWidth;
  // Updating font

  Label1.Font.Size := CalculateMazSize(Label1.Canvas, Label1.Caption, Label1.Width, Label1.Height);

  // Updating old values
  OldWidth := Width;
  OldHeight := Height;
end;

end.

这个问题的一个问题是，如果用户最大化表单，则无法工作，因为根据文档，只有在用户调整大小或移动表单时才会发送此消息。

在窗口退出移动或调整大小模态循环后，向窗口发送一次。当用户单击窗口的标题栏或调整大小边框，或者窗口将WM_SYSCOMMAND消息传递给DefWindowProc函数并且消息的wParam参数指定SC_MOVE或SC_SIZE值时，窗口进入移动或调整大小模态循环。当DefWindowProc返回时，操作完成。

- Nasreddine Galfout

---

这似乎解决了我遇到的问题，我猜我错过了根据表单调整实际标签高度/宽度...谢谢您的快速回答 :) 非常感谢，我开始对此感到沮丧。 - Eddy

Answer 2

我修改了David的函数LargestFontSizeToFitWidth，使其可以计算高度；

function LargestFontSizeToFitHeight(Canvas: TCanvas; Text: string; 
  height: Integer): Integer;
var
  Font: TFont;
  FontRecall: TFontRecall;
  InitialTextHeight: Integer;
begin
  Font := Canvas.Font;
  FontRecall := TFontRecall.Create(Font);
  try
    InitialTextHeight := Canvas.TextHeight(Text);
    Font.Size := MulDiv(Font.Size, height, InitialTextHeight);

    if InitialTextHeight < height then
    begin
      while True do
      begin
        Font.Size := Font.Size + 1;
        if Canvas.TextHeight(Text) > height then
        begin
          Result := Font.Size - 1;
          exit;
        end;
      end;
    end;

    if InitialTextHeight > height then
    begin
      while True do
      begin
        Font.Size := Font.Size - 1;
        if Canvas.TextHeight(Text) <= height then
        begin
          Result := Font.Size;
          exit;
        end;
      end;
    end;
  finally
    FontRecall.Free;
  end;
end;

将它们用于表单的调整大小事件；

procedure TForm1.FormResize(Sender: TObject);
 var
  x,y:Integer;
begin
  x := LargestFontSizeToFitHeight(Label1.Canvas, Label1.Caption, Label1.Height);
  y := LargestFontSizeToFitWidth(Label1.Canvas, Label1.Caption, Label1.Width);  // David's original function
  if x > y then
    x := y;
  Label1.Font.Size := x;
end;

- sddk

---

将此放置在窗体调整大小上只会使程序崩溃，在WMExitSizeMove中，它只会从最大值到最小值再返回。LargestFontSizeToFitWidth部分似乎根本不起作用，因为标签控件的TextWidth和Width始终相同。这是因为我将标签锚定在左侧、右侧、顶部和底部吗？还有其他什么方法可以调整控件大小吗？ - Eddy

这个有点故障。被接受的答案更好。 - Xel Naga