paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-08-17 21:59:16 +02:00
Code Issues Packages Projects Releases Wiki Activity

LCL: Fix TCustomLabel.CalcFittingFontHeight. Issue #31538, patch from Serge Anvarov.

Browse Source 
git-svn-id: trunk@54560 -
This commit is contained in:
juha 2017-04-07 16:59:49 +00:00
parent 0e3f65c569
commit 760d03b2bb
2 changed files with 61 additions and 53 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

92
lcl/include/customlabel.inc
View File

@ -313,65 +313,73 @@ end;
-------------------------------------------------------------------------------} -------------------------------------------------------------------------------}
function TCustomLabel.CalcFittingFontHeight(const TheText: string; function TCustomLabel.CalcFittingFontHeight(const TheText: string;
MaxWidth, MaxHeight: Integer; MaxWidth, MaxHeight: Integer;
var FontHeight, NeededWidth, NeededHeight: integer): Boolean; out FontHeight, NeededWidth, NeededHeight: Integer): Boolean;
var var
R : TRect; R: TRect;
DC : hDC; DC: HDC;
Flags: Cardinal; DrawFlags: UINT;
OldFont: HGDIOBJ; OldFont: HGDIOBJ;
MinFontHeight: Integer; MinFontHeight: Integer;
MaxFontHeight: Integer; MaxFontHeight: Integer;
AFont: TFont; TestFont: TFont;
CurFontHeight: LongInt; CurFontHeight: Integer;
begin begin
Result:=false; Result := False;
if AutoSizeDelayed or (TheText='') or (MaxWidth<1) or (MaxHeight<1) then exit; FontHeight := 0;
AFont:=TFont.Create; if AutoSizeDelayed or (TheText = '') or (MaxWidth < 1) or (MaxHeight < 1) then
AFont.Assign(Font); Exit;
CurFontHeight:=AFont.Height; TestFont := TFont.Create;
MinFontHeight:=5; try
MaxFontHeight:=MaxHeight*2; TestFont.Assign(Font);
if (CurFontHeight<MinFontHeight) or (CurFontHeight>MaxFontHeight) then MinFontHeight := 4;
CurFontHeight:=(MinFontHeight+MaxFontHeight) div 2; MaxFontHeight := MaxHeight * 2;
Flags := DT_CALCRECT or DT_NOPREFIX or DT_EXPANDTABS; CurFontHeight := (MinFontHeight + MaxFontHeight) div 2;
if WordWrap then inc(Flags, DT_WORDBREAK); DrawFlags := DT_CALCRECT or DT_NOPREFIX or DT_EXPANDTABS;
if WordWrap then
// give a clipping rectangle with space, so that the bounds returned by DrawFlags := DrawFlags or DT_WORDBREAK;
// DrawText can be bigger and we know, the tried font is too big. R.Left := 0;
R := Rect(0,0, MaxWidth, MaxHeight*2); R.Top := 0;
DC := GetDC(Parent.Handle); DC := GetDC(Parent.Handle);
try try
while (MinFontHeight<=MaxFontHeight) and (CurFontHeight>=MinFontHeight) while (MinFontHeight <= MaxFontHeight) and
and (CurFontHeight<=MaxFontHeight) do begin (CurFontHeight >= MinFontHeight) and
AFont.Height:=CurFontHeight; // NOTE: some TFont do not allow any integer (CurFontHeight <= MaxFontHeight) do
begin
TestFont.Height := CurFontHeight; // NOTE: some TFont do not allow any integer
//debugln('TCustomLabel.CalcFittingFontHeight A ',dbgs(MinFontHeight),'<=',dbgs(AFont.Height),'<=',dbgs(MaxFontHeight)); //debugln('TCustomLabel.CalcFittingFontHeight A ',dbgs(MinFontHeight),'<=',dbgs(AFont.Height),'<=',dbgs(MaxFontHeight));
OldFont := SelectObject(DC, HGDIOBJ(AFont.Reference.Handle)); OldFont := SelectObject(DC, HGDIOBJ(TestFont.Reference.Handle));
DrawText(DC, PChar(TheText), Length(TheText), R, Flags); R.Right := MaxWidth;
R.Bottom := MaxHeight;
DrawText(DC, PChar(TheText), Length(TheText), R, DrawFlags);
SelectObject(DC, OldFont); SelectObject(DC, OldFont);
NeededWidth := R.Right - R.Left; NeededWidth := R.Right - R.Left;
NeededHeight := R.Bottom - R.Top; NeededHeight := R.Bottom - R.Top;
//debugln('TCustomLabel.CalcFittingFontHeight B NeededWidth=',dbgs(NeededWidth),' NeededHeight=',dbgs(NeededHeight),' MaxWidth=',dbgs(MaxWidth),' MaxHeight=',dbgs(MaxHeight)); //debugln('TCustomLabel.CalcFittingFontHeight B NeededWidth=',dbgs(NeededWidth),' NeededHeight=',dbgs(NeededHeight),' MaxWidth=',dbgs(MaxWidth),' MaxHeight=',dbgs(MaxHeight));
if (NeededWidth>0) and (NeededHeight>0) if (NeededWidth in [1..MaxWidth]) and (NeededHeight in [1..MaxHeight]) then
and (NeededWidth<=MaxWidth) and (NeededHeight<=MaxHeight) then begin begin
// TheText fits into the bounds // TheText fits into the bounds
if (not Result) or (FontHeight<AFont.Height) then if (not Result) or (FontHeight < TestFont.Height) then
FontHeight:=AFont.Height; FontHeight := TestFont.Height;
Result:=true; Result := True;
MinFontHeight:=CurFontHeight; MinFontHeight := CurFontHeight;
// -> try bigger (binary search) // -> try bigger (binary search)
CurFontHeight:=(MaxFontHeight+CurFontHeight+1) div 2; // +1 to round up CurFontHeight := (MaxFontHeight + CurFontHeight +1 ) div 2; // +1 to round up
if CurFontHeight=MinFontHeight then break; if CurFontHeight = MinFontHeight then
end else begin Break;
// TheText does not fit into the bounds
MaxFontHeight:=CurFontHeight-1;
// -> try smaller (binary search)
CurFontHeight:=(MinFontHeight+CurFontHeight) div 2;
end;
end 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 finally
ReleaseDC(Parent.Handle, DC); ReleaseDC(Parent.Handle, DC);
AFont.Free; end;
finally
TestFont.Free;
end; end;
end; end;

4
lcl/stdctrls.pp
View File

@ -1533,8 +1533,8 @@ type
public public
constructor Create(TheOwner: TComponent); override; constructor Create(TheOwner: TComponent); override;
function CalcFittingFontHeight(const TheText: string; function CalcFittingFontHeight(const TheText: string;
MaxWidth, MaxHeight: Integer; var FontHeight, MaxWidth, MaxHeight: Integer;
NeededWidth, NeededHeight: integer): Boolean; out FontHeight, NeededWidth, NeededHeight: Integer): Boolean;
function ColorIsStored: boolean; override; function ColorIsStored: boolean; override;
function AdjustFontForOptimalFill: Boolean; function AdjustFontForOptimalFill: Boolean;
procedure Paint; override; procedure Paint; override;