I'm tyring calculate the maximum fontsize in order for at Text to fit into the ClientRect of a TCxLabel. But I cant get it to work probably. (See picture)
The fontsize is to big and the thxt is not drawn the corrent place.
Here how to reproduce:
Place a tcxLabel on an empty Form, and allign the label to client
Add a FormCreate and a FormResize event :
procedure TForm48.FormCreate(Sender: TObject);
begin
CalculateNewFontSize;
end;
procedure TForm48.FormResize(Sender: TObject);
begin
CalculateNewFontSize;
end;
and Finally implement CalculateNewFontSize :
uses
Math;
procedure TForm48.CalculateNewFontSize;
var
ClientSize, TextSize: TSize;
begin
ClientSize.cx := cxLabel1.Width;
ClientSize.cy := cxLabel1.Height;
cxLabel1.Style.Font.Size := 10;
TextSize := cxLabel1.Canvas.TextExtent(Text);
if TextSize.cx * TextSize.cx = 0 then
exit;
cxLabel1.Style.Font.Size := cxLabel1.Style.Font.Size * Trunc(Min(ClientSize.cx / TextSize.cx, ClientSize.cy / TextSize.cy) + 0.5);
end;
Does any one know how to calculate the font size and ho to place the text correctly?
I'd use something along these lines:
function LargestFontSizeToFitWidth(Canvas: TCanvas; Text: string;
Width: Integer): Integer;
var
Font: TFont;
FontRecall: TFontRecall;
InitialTextWidth: Integer;
begin
Font := Canvas.Font;
FontRecall := TFontRecall.Create(Font);
try
InitialTextWidth := Canvas.TextWidth(Text);
Font.Size := MulDiv(Font.Size, Width, InitialTextWidth);
if InitialTextWidth < Width then
begin
while True do
begin
Font.Size := Font.Size + 1;
if Canvas.TextWidth(Text) > Width then
begin
Result := Font.Size - 1;
exit;
end;
end;
end;
if InitialTextWidth > Width then
begin
while True do
begin
Font.Size := Font.Size - 1;
if Canvas.TextWidth(Text) <= Width then
begin
Result := Font.Size;
exit;
end;
end;
end;
finally
FontRecall.Free;
end;
end;
Make an initial estimate, and then fine tune by modifying the size by increments of one at a time. This is easy to understand and verify for correctness, and also quite efficient. In typical use the code will call TextWidth only a handful of times.
Text size doesn't depend linearly on font size. So you would better to increment or decrement font size by one and calculate text sizes, or find needed size with binary search (preferable, if size differs significantly)
Related
I want to draw on a canvas a word vertically and next to it a word horizontally.
I used a old suggestion like this :
in the maiForm's create event :
GetObject(MainForm.Font.Handle,SizeOf(TLogFont),#LogFont);
NewLogFont := LogFont;
NewLogFont.lfEscapement := 900;
NewFont := CreateFontIndirect(NewLogFont);
OldFont := MainForm.Font.Handle;
where
LogFont,NewLogFont : TLogFont;
NewFont,OldFont : HFont;
and in drawing routine :
fontTemp := TFont.Create;
fontTemp.Assign(aCanvas.Font);
......
aCanvas.Font.Handle := newFont; // if i coment this line the two strings drawn verically else both drawn horizonatlly
aCanvas.Font.Size := 8;
h := textHeight('1');
aCanvas.textOut(x,y,aString);
aCanvas.Font.Assign(fontTemp);
aCanvas.textOut(x+20,y,bString);
.....
fontTemp.Free;
In my old application (D2007) it worked ok but in Delphi 10.2, the change of orientation (from vert to horiz) changes both strings to horiz.
Any help please ?
No, as you said it is not an absolutely rare code. This approach lets you rotate text without using VCL's canvas properties.
Pure WinAPI for output text with rotation
The code below uses no VCL's capabilities to output rotated text onto provided device context (HDC).
procedure TForm1.DrawTextRotatedA(ADC: HDC; AFontHandle: HFONT;
Angle, X, Y: Integer; AColor: COLORREF; AText: String);
var
LogFont: tagLOGFONT;
OldFontHandle: HFONT;
NewFontHandle: HFONT;
begin
if (ADC = 0) or (AFontHandle = 0) then
Exit;
if GetObject(AFontHandle, SizeOf(LogFont), #LogFont) = 0 then
Exit;
// Set color of text and its rotation angle
SetTextColor(ADC, AColor);
if Angle > 360 then
Angle := 0;
LogFont.lfEscapement := Angle * 10;
LogFont.lfCharset := 1;
LogFont.lfOutPrecision := OUT_TT_PRECIS;
LogFont.lfQuality := PROOF_QUALITY;
// Create new font
NewFontHandle := CreateFontIndirect(LogFont);
try
OldFontHandle := SelectObject(ADC, NewFontHandle);
try
// Output result
SetBKMode(ADC, TRANSPARENT);
try
TextOut(ADC, X, Y, LPCWSTR(AText), Length(AText));
finally
SetBKMode(ADC, OPAQUE);
end;
finally
// Restore font handle
NewFontHandle := SelectObject(ADC, OldFontHandle);
end;
finally
// Delete font handle
DeleteObject(NewFontHandle);
end;
end;
There are places for improvements but this is just an example to prove you are wrong calling such a code rare. This example expects HFONT as one of arguments to perform all actions over it. You probably could get font handle from TControl by using WM_GETFONT message, but most of VCL's components don't honor this message (it works, f.e. with TListView which returns correct font handle). Trying to get font handle from HDC returns System font that doesn't support rotation at all. Perhaps I did something wrong but I have acted accordingly to microsoft.docs.
Using VCL for output text with rotation
I didn't get what code you have provide in your question should to do (it is cannot be compiled) so I rewrite it to show you how to output rotated text with using VCL's capabilities.
procedure TForm1.DrawTextRotatedB(ACanvas: TCanvas; Angle, X, Y: Integer;
ATextColor: TColor; AText: String);
var
NewX: Integer;
NewY: integer;
Escapement: Integer;
LogFont: TLogFont;
NewFontHandle: HFONT;
OldFontHandle: HFONT;
begin
if not Assigned(ACanvas) then
Exit;
// Get handle of font and prepare escapement
GetObject(ACanvas.Font.Handle, SizeOf(LogFont), #LogFont);
if Angle > 360 then
Angle := 0;
Escapement := Angle * 10;
// We must initialise all fields of the record structure
LogFont.lfWidth := 0;
LogFont.lfHeight := ACanvas.Font.Height;
LogFont.lfEscapement := Escapement;
LogFont.lfOrientation := 0;
if fsBold in ACanvas.Font.Style then
LogFont.lfWeight := FW_BOLD
else
LogFont.lfWeight := FW_NORMAL;
LogFont.lfItalic := Byte(fsItalic in ACanvas.Font.Style);
LogFont.lfUnderline := Byte(fsUnderline in ACanvas.Font.Style);
LogFont.lfStrikeOut := Byte(fsStrikeOut in ACanvas.Font.Style);
LogFont.lfCharSet := ACanvas.Font.Charset;
LogFont.lfOutPrecision := OUT_DEFAULT_PRECIS;
LogFont.lfClipPrecision := CLIP_DEFAULT_PRECIS;
LogFont.lfQuality := DEFAULT_QUALITY;
LogFont.lfPitchAndFamily := DEFAULT_PITCH;
StrPCopy(LogFont.lfFaceName, ACanvas.Font.Name);
// Create new font with rotation
NewFontHandle := CreateFontIndirect(LogFont);
try
// Set color of text
ACanvas.Font.Color := ATextColor;
// Select the new font into the canvas
OldFontHandle := SelectObject(ACanvas.Handle, NewFontHandle);
try
// Output result
ACanvas.Brush.Style := VCL.Graphics.bsClear;
try
ACanvas.TextOut(X, Y, AText);
finally
ACanvas.Brush.Style := VCL.Graphics.bsSolid;
end;
finally
// Restore font handle
NewFontHandle := SelectObject(ACanvas.Handle, OldFontHandle);
end;
finally
// Delete the deselected font object
DeleteObject(NewFontHandle);
end;
end;
Using case
Here is the code showing how to use procedures for rotating text.
procedure TForm1.aButton1Click(Sender: TObject);
var
DC: HDC;
begin
Repaint;
DC := GetDC(Handle);
try
DrawTextRotatedA(DC, Canvas.Font.Handle, TrackBar1.Position, 100, 100, clNavy, 'String');
finally
ReleaseDC(Handle, DC);
end;
DrawTextRotatedB(Canvas, TrackBar1.Position, 200, 100, clNavy, 'String');
end;
Sometimes it is faster to output rotated text onto DC without VCL. This could be useful if you are trying to deal with control that have no access to canvas. F.e. if you will try to paint tooltip (tooltip_class32) in your own style you probably might want to use the first method to output text (rotated or not).
Information
Here are links from docs.microsoft. they describe how and why one or another function was used.
About Device Contexts
TextOutW function
SetTextColor function
tagLOGFONTW structure
GetObject function
WM_GETFONT message
It's simple!
TFont has the property orientation that does the work! All this stuf I used is absolutely rare.
I need to get the number of displayed lines in TMemo (this include the lines that was wrapped because WordWrap is set to true). I need this to auto adjust the height of the Tmemo to it's content.
lines.count of course don't care about wrapped lines so i can't use it. strangely TextPosToPos also don't care about wrapped lines so i can't use it too ...
I m under firemonkey and delphi Berlin
Edit after I learned about ContentsBounds. My original (and obsolete) answer is still visible in the revisions.
Why do you need the number of displayed lines to adjust the height of the TMemo? This resizes the TMemo to its content:
Memo1.Height := Memo1.ContentBounds.Height + 5; // Small const to allow for rendering margins
It also takes word-wrap into consideration.
I don't know why using ContentBounds is "not really ideal". Here's how I do it:
uses
FMX.TextLayout, FMX.Graphics;
function MeasureTextHeight(const AFont: TFont; const AText: string): Single;
var
LLayout: TTextLayout;
begin
LLayout := TTextLayoutManager.DefaultTextLayout.Create;
try
LLayout.BeginUpdate;
try
LLayout.WordWrap := False;
LLayout.Font.Assign(AFont);
LLayout.Text := AText;
finally
LLayout.EndUpdate;
end;
Result := LLayout.TextHeight;
finally
LLayout.Free;
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
var
LTextHeight: Single;
LLines: Integer;
begin
LTextHeight := MeasureTextHeight(Memo1.TextSettings.Font, Memo1.Text);
LLines := Round(Memo1.ContentBounds.Height / LTextHeight);
end;
This is the rough way i use to calculate the number of lines an TMemo (styled) under firemonkey :
type
_TStyledMemoProtectedAccess = class(TStyledMemo);
procedure TALStyledMemo.OnApplyStyleLookupImpl(sender: Tobject);
Var I, j, k, l: integer;
begin
// TALStyledMemo
// TStyledMemo
// TLayout
// TActiveStyleObject
// TLayout
// TScrollBar
// TScrollBar
// TLayout
// TSmallScrollBar
// TSmallScrollBar
// TScrollContent
for I := 0 to controls.Count - 1 do begin
if (controls[i] is TStyledMemo) then begin // << TStyledMemo
fStyledMemo := TStyledMemo(controls[i]);
end;
end;
end;
function TALStyledMemo.getLineHeight: Single;
begin
if fStyledMemo <> nil then result := _TStyledMemoProtectedAccess(fStyledMemo).GetLineHeight
else result := 0;
end;
function TALStyledMemo.getLineCount: integer;
var aLineHeight: Single;
begin
aLineHeight := getLineHeight;
if compareValue(aLineHeight, 0, Tepsilon.Position) > 0 then result := round(ContentBounds.Height / aLineHeight)
else result := 0;
end;
How do you get the label height to automatically adjust when resizing the form? All of the properties are set. Align is top. Autosize is true. Word wrap is true.
When I change the form size the label adjust the caption fine. However, the actual label will not resize its height.
This leaves a gap when the form width is increasing or it leaves the bottom part of the caption unreadable. Makes it ugly when you have controls below the label that should move up or down depending on the label's height.
I would hate to do this using the form's resize event. Too bad there is no form "resize end" event.
Any help? Thanks.
If I recall correctly, with Autosize set to true, the height of the label is automatically set to the actual height of the text in Caption.
You might try setting Autosize to false and see how that works for you.
I've solved by inheriting from tlabel.
there is a bug with the autosize in this case (autosize, wordwrap and alTop)
to make it recalculate it size you need to:
AutoSize := false;
AutoSize := true;
so you can override the resize procedure like that:
procedure TResizableLabel.Resize;
begin
AutoSize := false;
AutoSize := true;
end;
however if you will do it on every resize it will shrink the width also, so you will lose the width of the parent from alTop, in case it is just aligned left it will probably be ok, but if you want center or right alignment you will need a better solution.
this is the full solution, it will call the autosize only when needed:
TResizableLaber = class(TLabel)
protected
FTextHeight, FTextWidth : integer;
function GetCaption : TCaption;
procedure SetCaption(ACaption : TCaption);
function GetFont : TFont;
procedure SetFont(AFont : TFont);
public
procedure Resize; override;
property Caption : TCaption read GetCaption write SetCaption;
property Font : TFont read GetFont write SetFont;
end;
implementation
procedure TResizableLaber.Resize;
var
num : double;
begin
inherited;
if AutoSize then
begin
if (FTextHeight = 0) or (FTextWidth = 0) then
begin
//lazy evaluation, we re evaluate every time the caption or font changes
FTextWidth := Utills.GetTextWidth(Caption, Font);
FTextHeight := Utills.GetTextHeight(Caption,Font);
end;
//TODO: there is still one bug here, set alCenter and make the last word long enough so it cant always wrapped to the line before, even though there is globally enough space
num := ( Height / FTextHeight) - (FTextWidth /Width );
//if num is greater then 1 it means we need an extra line, if it is lower then zero it means there is an extra line
if (num > 1) or (num < 0) then
begin
//just doing this all the time will cause it to really resize and will break alTop matching the whole space
AutoSize := false;
AutoSize := true;
end;
end;
end;
function TResizableLaber.GetCaption : TCaption;
begin
Result := inherited Caption;
end;
procedure TResizableLaber.SetCaption(ACaption : TCaption);
begin
FTextWidth := Utills.GetTextWidth(ACaption, Self.Font);
FTextHeight := Utills.GetTextHeight(ACaption,Self.Font);
inherited Caption := ACaption;
end;
function TResizableLaber.GetFont : TFont;
begin
Result := inherited Font;
end;
procedure TResizableLaber.SetFont(AFont : TFont);
begin
FTextWidth := Utills.GetTextWidth(Caption, AFont);
FTextHeight := Utills.GetTextHeight(Caption,AFont);
inherited Font := AFont;
end;
class function Utills.GetTextHeight(const Text:String; Font:TFont) : Integer;
var
bitmap: TBitmap;
begin
bitmap := TBitmap.Create;
try
bitmap.Canvas.Font := Font;
Result := bitmap.Canvas.TextHeight(Text);
finally
bitmap.Free;
end;
end;
class function Utills.GetTextWidth(const Text:String; Font:TFont) : Integer;
var
bitmap: TBitmap;
begin
bitmap := TBitmap.Create;
try
bitmap.Canvas.Font := Font;
Result := bitmap.Canvas.TextWidth(Text);
finally
bitmap.Free;
end;
end;
I've spent quite some time to get both the wordwrap and the height of a series of labels right. The previous answer (thanks ndori), using the pointless-looking solution of first making Autosize false, followed by setting it to true is the solution!
Below my code for publishing a (long) series of labels, where the caption text is generated somewhere else and can be as short as one character up to several lines of text. So, I need a fixed label width, active wordwrap and a constant white space between all different labels.
When resizing the form the label.width (arbitrary set to 560 below) may be adjusted to fit the new form when resizing. I think the real problem is getting the label heights correctly displayed.
{ AL[] = global variable: array of TLabel
{ AL[].caption (the text) is delivered elsewhere, and can be short or long (= multiline text)
{ N_ActiveLabels = global integer variable: # of active labels to publish }
procedure PublishListOfLabels;
var
i : integer;
begin
AL[0].Top := 15; // or whatever
AL[0].Visible := true;
AL[0].Width := 560; // (re)set this here as otherwise the wordwrap makes
// the label text a long narrow column!
AL[0].AutoSize := false; // THIS IS REQUIRED!
AL[0].AutoSize := true; // THIS IS REQUIRED!
if N_ActiveLabels > 1 then begin
for i := 1 to N_ActiveLabels -1 do begin
AL[i].Visible := true;
AL[i].Width := 560;
AL[i].AutoSize := false;
AL[i].AutoSize := true;
AL[i].Top := AL[i-1].Top + AL[i-1].Height + 18;
// 18 was chosen as vertical white space between any two labels
end;
end;
end;
I found repainting (or refreshing) of the labels not needed.
I also encountered solutions like:
H := AL[i].Canvas.TextHeight(AL[i].caption);
where H is supposed to contain the real height of AL[i] (after filling its caption with text and calling PublishListOfLabels. it is NOT working.
I mention this as this solution has been proposed at several other places dealing with the same issue (getting a correct TLabel height).
[I use Berlin 10.1 - perhaps later versions have solved the Autosize.false /.true aberation]
This question already has answers here:
Closed 10 years ago.
Possible Duplicate:
Can I make a TMemo size itself to the text it contains?
Need to do autosize memo: height and width.
I autosize the height as follows:
function TForm1.AutoSizeMemoY(Memo: TMemo): word;
begin
Canvas.Font := Memo.Font;
Result := Canvas.TextExtent(Memo.Lines.Strings[0]).cy * Memo.Lines.Count +
Canvas.TextExtent(Memo.Lines.Strings[0]).cy;
end;
But I do not know how to do autosize the width. I have an idea: if the scrollbar is activated, then increase the width until it becomes inactive, but I do not know how to implement that.
Not the best solution but it works:
function GetTextWidth(F: TFont; s: string): integer;
var
l: TLabel;
begin
l := TLabel.Create(nil);
try
l.Font.Assign(F);
l.Caption := s;
l.AutoSize := True;
result := l.Width + 8;
finally
l.Free;
end;
end;
And add following code to the end of Memo1.Onchange event in this answer
LineInd := Memo1.Perform(EM_LINEFROMCHAR, Memo1.SelStart, 0);//focused Memo1 line Index
Wd := GetTextWidth(Memo1.Font, Memo1.Lines[LineInd]);
//MaxWidthLineInd = index of the line which has the largest width.
//Init value of MaxWidthLineInd = 0
if MaxWidthLineInd = LineInd then
Memo1.Width := Wd
else begin
if Wd > Memo1.Width then
begin
Memo1.Width := Wd;
MaxWidthLineInd := LineInd;
end;
end;
I am creating a number of dynamically created THTMLabels but after these are created,when I try to get it's height,it always return the default height value.
Here is my code:
for i := 0 to ASentencePtr^.MUS.Count - 1 do
begin
j := Random(slTemp.Count);
sSen := ASentencePtr^.MUS.Strings[StrToInt(slTemp.Strings[j])] + ' / ';
THTMLabel.Create(Self).Name := 'lblSen_' + slTemp.Strings[j];
with THTMLabel(FindComponent('lblSen_' + slTemp.Strings[j])) do
begin
Font.Size := 18;
Font.Style := [fsBold];
Parent := FlowPanel1;
Width := Parent.Width;
Cursor := crHandPoint;
DragMode := dmAutomatic;
ControlStyle := ControlStyle + [csDisplayDragImage];
HTMLText.Add(sSen);
Autosizing := True;
end;
slTemp.Delete(j);
end;
Now when I try to access THTMLabel(FindComponent('lblSen_0')).Height, it returns only the default value which is 17. Where have I gone wrong? Any thoughts anyone? Any help is greatly appreciated, thanks.
We had the same problems but managed to solve them with the THTMLStaticText component and this function that calculates the height when dynamically (height) adjusted:
function CalculateDynamicHeight( aLabel: TLabel; htmlStaticText: THTMLStaticText): Integer;
var
lRect : TRect;
lText : string;
begin
lRect := Rect( 0, 0, htmlStaticText.Width, 0);
lText := htmlStaticText.Text;
aLabel.Caption := htmlStaticText.Text;
aLabel.Font := htmlStaticText.Font;
aLabel.Canvas.Font := htmlStaticText.Font;
aLabel.Canvas.TextRect(
{var} lRect, //will be modified to fit the text dimensions
{var} lText, //not modified, unless you use the "tfModifyingString" flag
[tfCalcRect, tfWordBreak] //flags to say "compute text dimensions with line breaks"
);
ASSERT( lRect.Top = 0 ); //this shouldn't have moved
aLabel.Height := lRect.Bottom;
Result := lRect.Bottom;
end;
The function requires a TLabel component, used exclusively for calculation purposes (you can set the visibility to false). The htmlStaticText component should have AutoSize set to true (in our case AutoSizeType is set to asVertical) and the htmlStaticText.Text should be present when calling the function.
I think THTMLLabel is part of the Jedi Library, itsn't? This problem is weird. I don't know the implementation of this control, but if you are having this problem, then there's may be a very bad implementation of the AutoSize Property.
If you can't inspect and fix the source of this control, try to use the BoundsRect property to get the height:
LabelHeight := THTMLabel(FindComponent('lblSen_0')).BoundsRect.Bottom;