cxScalableLabel

unit cxScalableLabel;

interface

uses
  Classes, Graphics,
  cxControls, cxLabel, cxGraphics;

type
  TcxScalableLabel = class(TcxLabel, IcxLockedStateFontChanged)
  protected
    procedure FontChanged(AFont: TFont);
    procedure TextChanged; override;
    procedure Resize; override;
    function CalculateMazSize: Integer;
  public
    constructor Create(aOwner: TComponent); override;
  end;

implementation

uses
  Windows, Math;
{ TcxScalableLabel }

function TcxScalableLabel.CalculateMazSize: Integer;
  function LargestFontSizeToFitWidth: Integer;
  var
    Font: TFont;
    FontRecall: TFontRecall;
    InitialTextWidth: Integer;
  begin
    Font := Canvas.Font;
    Result := Font.Size;
    FontRecall := TFontRecall.Create(Font);
    try
      InitialTextWidth := Canvas.TextWidth(Caption);
      Font.Size := MulDiv(Font.Size, Width, InitialTextWidth);

      if InitialTextWidth < Width then
        while True do
        begin
          Font.Size := Font.Size + 1;
          if Canvas.TextWidth(Caption) > Width then
            exit(Font.Size - 1);
        end;

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

  function LargestFontSizeToFitHeight: Integer;
  var
    Font: TFont;
    FontRecall: TFontRecall;
    InitialTextHeight: Integer;
  begin
    Font := Canvas.Font;
    Result := Font.Size;
    FontRecall := TFontRecall.Create(Font);
    try
      InitialTextHeight := Canvas.TextHeight(Caption);
      Font.Size := MulDiv(Font.Size, Height, InitialTextHeight);

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

      if InitialTextHeight > Height then
        while True do
        begin
          Font.Size := Font.Size - 1;
          if Canvas.TextHeight(Caption) <= Height then
            exit(Font.Size);
        end;

    finally
      FontRecall.Free;
    end;
  end;

begin
  if Caption <> '' then
    Result := Min(LargestFontSizeToFitWidth, LargestFontSizeToFitHeight)
  else
    Result := Style.Font.Size;
end;

constructor TcxScalableLabel.Create(aOwner: TComponent);
begin
  inherited;
  FontListenerList.Add(Self);
end;

procedure TcxScalableLabel.FontChanged(AFont: TFont);
var
  NewSize: Integer;
begin
  NewSize := CalculateMazSize;
  if AFont.Size <> NewSize then
    Style.Font.Size := NewSize;
end;

procedure TcxScalableLabel.Resize;
begin
  inherited;
  Style.Font.Size := CalculateMazSize;
end;

procedure TcxScalableLabel.TextChanged;
begin
  inherited;
  Style.Font.Size := CalculateMazSize;
end;

end.