* * *

Author Topic: AutoSize TMemo.Height?  (Read 3610 times)

Avishai

  • Hero Member
  • *****
  • Posts: 1021
AutoSize TMemo.Height?
« on: November 04, 2013, 07:19:36 am »
Does someone know how to AutoSize the height of TMemo so that it displays all Lines?  I've tried several calculations but none of them seem to work.  I'm trying to avoid showing the scrollbars.
Lazarus Trunk / fpc 2.6.2 / Win32

taazz

  • Hero Member
  • *****
  • Posts: 5027
Re: AutoSize TMemo.Height?
« Reply #1 on: November 04, 2013, 09:20:47 am »
http://forum.lazarus.freepascal.org/index.php/topic,21305.msg124432.html#msg124432 the link provided has a sample that calculates the lines for a multiline grid along with word wrap to show the complete data of a memo field regardless the size of the column. You should be able to adapt it to your needs.
Good judgement is the result of experience … Experience is the result of bad judgement.

OS : Windows 7 64 bit
Laz: Lazarus 1.4.4 FPC 2.6.4 i386-win32-win32/win64

Avishai

  • Hero Member
  • *****
  • Posts: 1021
Re: AutoSize TMemo.Height?
« Reply #2 on: November 04, 2013, 10:13:05 am »
Thanks Taazz.  I'll look at it and see if I can use it some way.

In the meantime, I think I may have found at least part of the solution.

Code: [Select]
procedure TForm1.BitBtn3Click(Sender: TObject);
var
  c: TBitmap;
begin
  c := TBitmap.Create;
  try
    c.Canvas.Font.Assign(Memo1.Font);
    Edit2.Caption := IntToStr(c.Canvas.TextHeight('My String'));
  finally
    c.Free;
  end;
end;

For the font I'm using this returns 16 and the line spacing of the TMemo is 17 so I think I can get what I need from this.
Lazarus Trunk / fpc 2.6.2 / Win32

Avishai

  • Hero Member
  • *****
  • Posts: 1021
Re: AutoSize TMemo.Height?
« Reply #3 on: November 04, 2013, 03:00:16 pm »
OK, this is what I have come up with and it seems to work.

Code: [Select]
function GetTextHeight(ACtrl: TControl): Integer;
var
  C: TBitMap;
begin
  Result:= -1;
  C := TBitmap.Create;
  try
    C.Canvas.Font.Assign(ACtrl.Font);
    Result:= C.Canvas.TextHeight('TextHeight');
  finally
    C.Free;
  end;
end;

procedure TForm1.BitBtn3Click(Sender: TObject);
var
  H: Integer;
begin
  H:= GetTextHeight(Memo1);
  If H>-1 then
    Memo1.Height:= (H*Memo1.Lines.Count)+H div 2;
end;
Lazarus Trunk / fpc 2.6.2 / Win32

engkin

  • Hero Member
  • *****
  • Posts: 1952
Re: AutoSize TMemo.Height?
« Reply #4 on: November 04, 2013, 06:45:09 pm »
Avishai, nice solution. I can still see one problem, in long lines words wrap and that will add extra visible lines that Memo1.Lines.Count does *NOT* count for. I believe taazz has already produced a solution, DT_CALC is meant to do that math for you. Did you see his solution?

Avishai

  • Hero Member
  • *****
  • Posts: 1021
Re: AutoSize TMemo.Height?
« Reply #5 on: November 04, 2013, 06:57:22 pm »
engkin, what I am seeing is that Lines.Count does see word wrap, but I think I should give more info.  This is a read-only TMemo that displays predefined text.  TabStop is set False, but the user can select all or part of the text and copy it.
Lazarus Trunk / fpc 2.6.2 / Win32

CM630

  • Hero Member
  • *****
  • Posts: 801
  • Не съм сигурен, че те разбирам.
    • http://sourceforge.net/u/cm630/profile/
Re: AutoSize TMemo.Height?
« Reply #6 on: April 17, 2018, 12:04:24 pm »
I tried Taazz's solution (from the other thread).
Sample project won't compile.
Provided function (below) requires Canvas as a parameter, but TMemo does not have a (visible) Canvas property.
Code: Pascal  [Select]
  1. function QueryTextRect(const Canvas:TCanvas; const aText:String; const aFont:TFont; const MaxRect: TRect):TRect;
  2. const
  3.   DrawTextFlags = DT_NOPREFIX or DT_EDITCONTROL or DT_CALCRECT;
  4. begin
  5.   if (Text <> '') then
  6.   begin
  7.     Canvas.Font := aFont;
  8.     Result := MaxRect;
  9.     LCLIntf.DrawText(vCanvas.Handle, PChar(aText), Length(aText),  //calculate the text's rectangle required for painting.
  10.       Result, DrawTextFlags);
  11.   end
  12.   else
  13.     FillChar(Result, SizeOf(Result), 0);
  14. end;
« Last Edit: April 17, 2018, 01:00:47 pm by CM630 »
Лазар 1,8,0;W7 64bit or XP 32bit;FPC3,0,4;rev 56594

taazz

  • Hero Member
  • *****
  • Posts: 5027
Re: AutoSize TMemo.Height?
« Reply #7 on: April 17, 2018, 12:25:59 pm »
I tried Taaz's solution (from the other thread).


which thread that might be?
Good judgement is the result of experience … Experience is the result of bad judgement.

OS : Windows 7 64 bit
Laz: Lazarus 1.4.4 FPC 2.6.4 i386-win32-win32/win64

CM630

  • Hero Member
  • *****
  • Posts: 801
  • Не съм сигурен, че те разбирам.
    • http://sourceforge.net/u/cm630/profile/
Re: AutoSize TMemo.Height?
« Reply #8 on: April 17, 2018, 12:59:59 pm »
The thread quoted by Taazz in post 2 ;)
http://forum.lazarus.freepascal.org/index.php/topic,21305.msg124432.html#msg124432
Maybe I should have said „topic‟.
Лазар 1,8,0;W7 64bit or XP 32bit;FPC3,0,4;rev 56594

taazz

  • Hero Member
  • *****
  • Posts: 5027
Re: AutoSize TMemo.Height?
« Reply #9 on: April 17, 2018, 01:18:58 pm »
The thread quoted by Taazz in post 2 ;)
http://forum.lazarus.freepascal.org/index.php/topic,21305.msg124432.html#msg124432
Maybe I should have said „topic‟.
oops :) missed it. well if there is no canvas just create one here is a custom canvas that needs no controls used internally by simplegraph with the approprietly redefined function.
Code: Pascal  [Select]
  1.   TEvsCompatibleCanvas = class(TCanvas)               //WORKS
  2.    public
  3.      constructor Create;                            //CreateCompatibleDC -- MAPS TO LCLINTF
  4.      destructor Destroy; override;
  5.    end;
  6. function QueryTextRect(const aText:String; const aFont:TFont; const MaxRect: TRect):TRect;
  7. implementation
  8. uses lclintf;
  9.  
  10. function QueryTextRect(const aText:String; const aFont:TFont; const MaxRect: TRect):TRect;
  11. const
  12.   DrawTextFlags = DT_NOPREFIX or DT_EDITCONTROL or DT_CALCRECT;
  13. var
  14.   vCnv : TCanvas;
  15. begin
  16.   vCnv := TEvsCompatibleCanvas.Create;
  17.   try
  18.     if (Text <> '') then
  19.     begin
  20.       Canvas.Font := aFont;
  21.       Result := MaxRect;
  22.       LCLIntf.DrawText(vCanvas.Handle, PChar(aText), Length(aText),  //calculate the text's rectangle required for painting.
  23.         Result, DrawTextFlags);
  24.     end
  25.     else
  26.       FillChar(Result, SizeOf(Result), 0);
  27.   finally
  28.     vCnv.Free
  29.   end;
  30. end;
  31.  
  32. {$REGION ' TCompatibleCanvas '}
  33. { TEvsCompatibleCanvas }
  34. constructor TEvsCompatibleCanvas.Create;
  35. begin
  36.   inherited Create;
  37.   Handle := LCLIntf.CreateCompatibleDC(0);                                      //LCLINTF
  38. end;
  39.  
  40. destructor TEvsCompatibleCanvas.Destroy;
  41. var
  42.   DC: HDC;
  43. begin
  44.   DC := Handle;
  45.   Handle := 0;
  46.   if DC <> 0 then
  47.   {$IFDEF LCLWIN32}
  48.     DeleteObject(DC);
  49.   {$ELSE}
  50.     DeleteDC(DC);
  51.   {$ENDIF}
  52.   inherited Destroy;
  53. end;
  54. {$ENDREGION}
  55.  

Be warned everything was pieced together on the browser no compilation or testing took place.
« Last Edit: April 17, 2018, 01:20:50 pm by taazz »
Good judgement is the result of experience … Experience is the result of bad judgement.

OS : Windows 7 64 bit
Laz: Lazarus 1.4.4 FPC 2.6.4 i386-win32-win32/win64

CM630

  • Hero Member
  • *****
  • Posts: 801
  • Не съм сигурен, че те разбирам.
    • http://sourceforge.net/u/cm630/profile/
Re: AutoSize TMemo.Height?
« Reply #10 on: April 17, 2018, 03:03:46 pm »
I have fixed some issues and tried.
It does not work, but I think it should not- I suppose in order to works I have to set width of the canvas somehow, but it is not settable.
I have attached the sample.
« Last Edit: April 18, 2018, 08:06:03 am by CM630 »
Лазар 1,8,0;W7 64bit or XP 32bit;FPC3,0,4;rev 56594

RAW

  • Hero Member
  • *****
  • Posts: 650
Re: AutoSize TMemo.Height?
« Reply #11 on: April 17, 2018, 05:02:52 pm »
Code: Pascal  [Select]
  1. unit Unit1;
  2.  
  3. {$mode objfpc}{$H+}
  4.  
  5. interface
  6.  
  7. uses
  8.   Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs,
  9.   LCLIntf, LCLType, StdCtrls;
  10.  
  11. type
  12.  
  13.   { TForm1 }
  14.  
  15.   TForm1 = class(TForm)
  16.     Button1: TButton;
  17.     Button2: TButton;
  18.     Memo1: TMemo;
  19.     Memo2: TMemo;
  20.     procedure Button1Click(Sender: TObject);
  21.     procedure Button2Click(Sender: TObject);
  22.   private
  23.  
  24.   public
  25.  
  26.   end;
  27.  
  28. var
  29.   Form1: TForm1;
  30.  
  31. implementation
  32.  
  33. {$R *.lfm}
  34. { TForm1 }
  35. Function WordWrapHeight(S: String; Ft: TFont; cMaxWidth: Cardinal): Integer;
  36.   Var
  37.    R  : TRect;
  38.    BMP: TBitmap;
  39.  Begin
  40.   Result:= -1;
  41.   R  := Rect(0, 0, cMaxWidth, 0);
  42.   BMP:= TBitmap.Create;
  43.    Try
  44.     BMP.Canvas.Font.Assign(Ft);
  45.     Result:= DrawText
  46.     (BMP.Canvas.Handle, PChar(S), Length(S), R, dt_CalcRect Or dt_WordBreak);
  47.    Finally
  48.     BMP.Free;
  49.    End;
  50.  End;
  51.  
  52. procedure TForm1.Button1Click(Sender: TObject);
  53. var
  54.  str: String;
  55.  i: Integer;
  56. begin
  57.   For i:= 1 To 50
  58.   Do str:= str+'This Is Some Text '+IntToStr(i);
  59.  
  60.   Memo2.Text:= str;
  61. end;
  62.  
  63. procedure TForm1.Button2Click(Sender: TObject);
  64. begin
  65.   If WordWrapHeight(Memo2.Text, Memo1.Font, Memo1.ClientWidth)
  66.      < Memo1.ClientHeight
  67.   Then Memo1.ScrollBars:= ssNone
  68.   Else Memo1.ScrollBars:= ssVertical;
  69.  
  70.   Memo1.Text:= Memo2.Text;
  71. end;
  72.  
  73. end.
Windows 7 Pro (x64 Sp1) And Windows XP Pro (x86 Sp3) - LAZARUS 1.8.2 FPC 3.0.4 // 1.7 FPC 3.1.1

howardpc

  • Hero Member
  • *****
  • Posts: 2644
Re: AutoSize TMemo.Height?
« Reply #12 on: April 17, 2018, 05:26:08 pm »
As engkin pointed out in the thread referenced earlier, to successfully calculate the required height of a memo with wrapped text requires some way of emulating the widgetset wrapping, in order to know how many visible lines are present.
The following uses a routine taazz provided long ago. Unfortunately it works well only for ANSI text, and does not do so well with the Bulgarian text CM630 wants to use. So I have copied it and renamed it to make clear its limitations.
However, what follows is a start.
There are plenty of forum users who have the skill to write a fully utf8-aware wrapping emulation routine.

Code: Pascal  [Select]
  1. unit Unit1;
  2.  
  3. {$mode objfpc}{$H+}
  4.  
  5. interface
  6.  
  7. uses
  8.   Classes, Forms, Controls, Graphics, StdCtrls, LCLIntf, LCLType, Types;
  9.  
  10. type
  11.  
  12.   TForm1 = class(TForm)
  13.     Button1: TButton;
  14.     Memo1: TMemo;
  15.     procedure Button1Click(Sender: TObject);
  16.   end;
  17.  
  18.   function WrapAnsiText(Canvas: TCanvas; const Text: String; MaxWidth: Integer): String;
  19.  
  20.   function GetAnsiTextWrappedMemoHeight(aMemo: TMemo): Integer;
  21.  
  22. var
  23.   Form1: TForm1;
  24.  
  25. implementation
  26.  
  27. {$R *.lfm}
  28.  
  29. function WrapAnsiText(Canvas: TCanvas; const Text: String; MaxWidth: Integer): String;
  30. var
  31.   DC: HDC;
  32.   TextExtent: TSize;
  33.   S, P, E: PChar;
  34.   Line: String;
  35.   IsFirstLine: Boolean;
  36. begin
  37.   Result := '';
  38.   DC := Canvas.Handle;
  39.   IsFirstLine := True;
  40.   P := PChar(Text);
  41.   while P^ = ' ' do
  42.     Inc(P);
  43.   while P^ <> #0 do
  44.   begin
  45.     S := P;
  46.     E := Nil;
  47.     while (P^ <> #0) and (P^ <> #13) and (P^ <> #10) do
  48.     begin
  49.       GetTextExtentPoint(DC, S, P - S + 1, TextExtent{%H-});
  50.       if (TextExtent.CX > MaxWidth) and (E <> Nil) then
  51.       begin
  52.         if (P^ <> ' ') and (P^ <> ^I) then
  53.         begin
  54.           while (E >= S) do
  55.             case E^ of
  56.               '.', ',', ';', '?', '!', '-', ':',
  57.               ')', ']', '}', '>', '/', '\', ' ':
  58.                 Break;
  59.               else
  60.                 Dec(E);
  61.             end;
  62.           if E < S then
  63.             E := P - 1;
  64.         end;
  65.         Break;
  66.       end;
  67.       E := P;
  68.       Inc(P);
  69.     end;
  70.     if E <> Nil then
  71.     begin
  72.       while (E >= S) and (P^ = ' ') do
  73.         Dec(E);
  74.     end;
  75.     if E <> Nil then
  76.       SetString(Line, S, E - S + 1)
  77.     else
  78.       SetLength(Line, 0);
  79.     if (P^ = #13) or (P^ = #10) then
  80.       begin
  81.         Inc(P);
  82.         if (P^ <> (P - 1)^) and ((P^ = #13) or (P^ = #10)) then
  83.           Inc(P);
  84.         if P^ = #0 then
  85.           Line := Line + LineEnding;
  86.       end
  87.     else if P^ <> ' ' then
  88.       P := E + 1;
  89.     while P^ = ' ' do
  90.       Inc(P);
  91.     if IsFirstLine then
  92.     begin
  93.       Result := Line;
  94.       IsFirstLine := False;
  95.     end
  96.     else
  97.       Result := Result + LineEnding + Line;
  98.   end;
  99. end;
  100.  
  101. function GetAnsiTextWrappedMemoHeight(aMemo: TMemo): Integer;
  102. const
  103.   flags = DT_NOPREFIX or DT_EDITCONTROL or DT_CALCRECT or DT_WORDBREAK;
  104. var
  105.   wrappedText: String;
  106.   pWrap: PChar absolute wrappedText;
  107.   cnv: TControlCanvas;
  108.   r: TRect;
  109. begin
  110.   if not Assigned(aMemo) or (aMemo.Text = '') then
  111.     Exit(0);
  112.   cnv := TControlCanvas.Create;
  113.   try
  114.     cnv.Control := aMemo;
  115.     r := aMemo.ClientRect;
  116.     wrappedText := WrapAnsiText(cnv, aMemo.Text, aMemo.Width);
  117.     DrawText(cnv.Handle, pWrap, Length(aMemo.Text), r, flags);
  118.     Result := r.Height;
  119.   finally
  120.     cnv.Free;
  121.   end;
  122. end;
  123.  
  124. procedure TForm1.Button1Click(Sender: TObject);
  125. begin
  126.   Memo1.Text := 'afdлкйслакдф йдсалкйфдлксайфдклйдсайлкдасйлкдйклсдалкйдлс,асдфласйдфлксадйфлкдаслдфк асдфклйасдлкдфйклас асдлкфйсадлкфдйсавияуроиевяу асфлкдйлкдфсайдс';
  127.   Memo1.Height := GetAnsiTextWrappedMemoHeight(Memo1);
  128. end;
  129.  
  130. end.

taazz

  • Hero Member
  • *****
  • Posts: 5027
Re: AutoSize TMemo.Height?
« Reply #13 on: April 17, 2018, 09:39:57 pm »
OK, here is my quick and dirty solution. Add a label behind the memo, set its wrap and autosize property to true, make sure it has the same width and font as the memo, now set the label's caption to the memo's text and resize the memo to cover the label. Easy fast and no need to waste time with the pesky utf8 strings, or you could look up how the label does it. well I did my duty posted my 5 seconds wisdom back under my rock now :P
Good judgement is the result of experience … Experience is the result of bad judgement.

OS : Windows 7 64 bit
Laz: Lazarus 1.4.4 FPC 2.6.4 i386-win32-win32/win64

CM630

  • Hero Member
  • *****
  • Posts: 801
  • Не съм сигурен, че те разбирам.
    • http://sourceforge.net/u/cm630/profile/
Re: AutoSize TMemo.Height?
« Reply #14 on: April 18, 2018, 08:05:50 am »
Okay, I did:
Code: Pascal  [Select]
  1.   Memo1.Text := 'afdлкйслакдф йдсалкйфдлксайфдклйдсайлкдасйлкдйклсдалкйдлс,асдфласйдфлксадйфлкдаслдфк асдфклйасдлкдфйклас асдлкфйсадлкфдйсавияуроиевяу асфлкдйлкдфсайдс';
  2.   label1.AutoSize:=true;
  3.   label1.WordWrap:=True;
  4.   label1.Constraints.MinWidth:=memo1.Width;
  5.   label1.Constraints.MaxWidth:=memo1.Width;
  6.   label1.caption := 'afdлкйслакдф йдсалкйфдлксайфдклйдсайлкдасйлкдйклсдалкйдлс,асдфласйдфлксадйфлкдаслдфк асдфклйасдлкдфйклас асдлкфйсадлкфдйсавияуроиевяу асфлкдйлкдфсайдс';
  7.   Memo1.Height:= Label1.Height;
  8.  

Guess if it works?
No :(

1. There seems to be a bug in both TLabel and TMemo:
None of them wraps on the comma in „йдсалкйфдлксайфдклйдсайлкдасйлкдйклсдалкйдлс,асдфласйдфлксадйфлкдаслдфк‟.
2. TLabel does not wrap „йдсалкйфдлксайфдклйдсайлкдасйлкдйклсдалкйдлс,асдфласйдфлксадйфлкдаслдфк‟ at all, while TMemo does, when it comes to the end of the line.

Such long strings are likely to happen in file paths, so this case is not ignorable.
Maybe I could force additional wrappping for long words in TLabel (add a CrLf when widths exceeds characters). I should better look in TLabels code...

Just for the record, this is not Bulgarian, but just some randomly typed Cyrillic letters ;) 


Still, I have not tried or checked @RAW's code.

...or you could look up how the label does it...

Probably no need to look- it wraps first and then counts the lines and resizes. Should be pretty simple, when done internally.


BUT, I still cannot find in the source of LCL the word wrap routines used by TMemo. :'(
« Last Edit: April 19, 2018, 08:22:55 am by CM630 »
Лазар 1,8,0;W7 64bit or XP 32bit;FPC3,0,4;rev 56594

 

Recent

Get Lazarus at SourceForge.net. Fast, secure and Free Open Source software downloads Open Hub project report for Lazarus