调整窗体大小时调整标签字体大小

仅在顶部和左侧使用锚固件。然后在 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 此消息仅在用户调整表单大小或移动表单时发送。

在退出移动或调整大小后,发送一次到窗口 模态循环。窗口进入移动或调整大小模式循环 当 用户单击窗口的标题栏或大小边框 ,或当 窗口将WM\U SYSCOMMAND消息传递给DefWindowProc函数 消息的wParam参数指定SC\U移动或 SC\U大小值。DefWindowProc返回时,操作完成。

我修改了 David's function 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;