OptimalFill is not working correctly
Original Reporter info from Mantis: SergeAnvarov @SergeAnvarov
-
Reporter name: Serge Anvarov
Original Reporter info from Mantis: SergeAnvarov @SergeAnvarov
- Reporter name: Serge Anvarov
Description:
Error calculation in the method TLabel.CalcFittingFontHeight. When it calculates the optimum height the width of rectangle also change, so result is not achieved
Steps to reproduce:
This is a sample test with the corrected version:
TForm1 = class(TForm)
//...
private
FTestLabel: TLabel;
//...
uses Windows, StrUtils;
//...
function NewCalcFittingFontHeight(Self: TLabel; const TheText: string;
MaxWidth, MaxHeight: Integer;
out FontHeight, NeededWidth, NeededHeight: Integer): Boolean;
var
R: TRect;
DC: HDC;
DrawFlags: UINT;
TestFont: TFont;
OldFont: HGDIOBJ;
MinFontHeight: Integer;
MaxFontHeight: Integer;
CurFontHeight: Integer;
begin
Result := False;
FontHeight := 0;
if Self.AutoSizeDelayed or (TheText = '') or (MaxWidth < 1) or (MaxHeight < 1) then
Exit;
TestFont := TFont.Create;
try
TestFont.Assign(Self.Font);
MinFontHeight := 4;
MaxFontHeight := MaxHeight * 2;
CurFontHeight := (MinFontHeight + MaxFontHeight) div 2;
DrawFlags := DT_CALCRECT or DT_NOPREFIX or DT_EXPANDTABS;
if Self.WordWrap then
DrawFlags := DrawFlags or DT_WORDBREAK;
R.Left := 0;
R.Top := 0;
DC := GetDC(Self.Parent.Handle);
try
while (MinFontHeight <= MaxFontHeight) and
(CurFontHeight >= MinFontHeight) and
(CurFontHeight <= MaxFontHeight) do
begin
TestFont.Height := CurFontHeight;
OldFont := SelectObject(DC, HGDIOBJ(TestFont.Reference.Handle));
R.Right := MaxWidth;
R.Bottom := MaxHeight;
DrawText(DC, PChar(TheText), Length(TheText), R, DrawFlags);
SelectObject(DC, OldFont);
NeededWidth := R.Right - R.Left;
NeededHeight := R.Bottom - R.Top;
if (NeededWidth in [1..MaxWidth]) and (NeededHeight in [1..MaxHeight]) then
begin
// TheText fits into the bounds
if (not Result) or (FontHeight < TestFont.Height) then
FontHeight := TestFont.Height;
Result := True;
MinFontHeight := CurFontHeight;
// -> try bigger (binary search)
CurFontHeight := (MaxFontHeight + CurFontHeight + 1) div 2; // +1 to round up
if CurFontHeight = MinFontHeight then
Break;
end
else
begin
// TheText does not fit into the bounds
MaxFontHeight := CurFontHeight - 1;
// -> try smaller (binary search)
CurFontHeight := (MinFontHeight + CurFontHeight) div 2;
end;
end
finally
ReleaseDC(Self.Parent.Handle, DC);
end;
finally
TestFont.Free;
end;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
FTestLabel := TLabel.Create(Self);
FTestLabel.Parent := Self;
FTestLabel.AutoSize := False;;
FTestLabel.WordWrap := True;
FTestLabel.Width := 60;
FTestLabel.Height := 60;
end;
procedure TForm1.Button1Click(Sender: TObject);
var
LongText: string;
FontHeight, NeededWidth, NeededHeight: Integer;
begin
LongText := DupeString('Long text ', 20);
FontHeight := FTestLabel.Font.Height;
NeededWidth := FTestLabel.Width;
NeededHeight := FTestLabel.Height;
if FTestLabel.CalcFittingFontHeight(LongText, FTestLabel.Width, FTestLabel.Height,
FontHeight, NeededWidth, NeededHeight) then
begin
FTestLabel.Font.Height := FontHeight;
FTestLabel.Caption := LongText;
end;
end;
procedure TForm1.Button2Click(Sender: TObject);
var
LongText: string;
FontHeight, NeededWidth, NeededHeight: Integer;
begin
LongText := DupeString('Long text ', 20);
if NewCalcFittingFontHeight(FTestLabel, LongText, FTestLabel.Width, FTestLabel.Height,
FontHeight, NeededWidth, NeededHeight) then
begin
FTestLabel.Font.Height := FontHeight;
FTestLabel.Caption := LongText;
end;
end;