调整表单大小时标签字体大小调整

Question

我正在尝试获取它，因此当我调整表单大小时，该表单上的标签会调整大小 accordingly.For 只有当 'WMExitSizeMove' 程序触发时，才会发生值得调整大小的内容。编辑：我更喜欢一种不会调整大小超出或低于约束的比例方法

理想情况下，我希望根据表格增长或缩小的程度获得某种形式的 'scale' 值。然后我可以将这个比例因子应用于窗体/面板上的所有控件。

不过，我会接受标签字体大小将调整为 label.heights 属性的最大可能大小（我会使用宽度，但该值似乎不会像标题那样改变是静态的）。

我有一个标签，我把它放在窗体上，给它所有的锚点（左、右、上和下都是真的）设置约束，这样控件就不会看起来太小或太大。我希望标签文本大小在控件高度和宽度边界内尽可能大。我不希望当控件高度现在低于文本高度时发生裁剪，此时我希望标签文本的大小调整到新控件高度下可能的最大尺寸。

例子 label.font.size := 11; Label.Height := 15;

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

理论上下一个最好的 label.font.size 应该是 9，因为这里没有剪裁。

如果您需要更多描述或更好的说明，请告诉我。这是我最近的皇家 PITA。

TLDR：想要一个表单调整比例，以便我可以将其应用于所有控件，否则可以动态调整 label.font.sizes 的大小以适应调整大小时的新高度/宽度。

此外：我已经尝试我可能将其合并错误但是当我调整表单大小时宽度是静态的，因为它似乎与 textwidth 相关联。

编辑：事实上，我认为缩放方法是最好的，只是想不出我该怎么做。看来我的数学有点粗糙！还必须符合约束条件。

Answer 1

我已经修改了 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;

Answer 2

仅在顶部和左侧使用锚点。然后在 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.

一个问题是，如果用户最大化表单，那么它将不起作用，因为基于 the documentation 此消息仅在用户调整表单大小时或移动表单时发送。

Sent one time to a window, after it has exited the moving or sizing modal loop. The window enters the moving or sizing modal loop when the user clicks the window's title bar or sizing border, or when the window passes the WM_SYSCOMMAND message to the DefWindowProc function and the wParam parameter of the message specifies the SC_MOVE or SC_SIZE value. The operation is complete when DefWindowProc returns.

调整表单大小时标签字体大小调整

Label font resizing when form resizes

forms

delphi

label

resize

scale