?
Solved

RTF Text Height

Posted on 2009-02-08
31
Medium Priority
?
2,118 Views
Last Modified: 2013-11-23
PART 1: I need some code to return the height of some RTF Text (as it would be displayed).
PART 2: I need some code to draw RTF Text in the DrawColumnCell
PART 3: (for bonus points) I want to convert a non RTF sting field into RTF formatted text and insert it on the top of the RTF Memo as a title.

If someone can solve part 1 for me I can probably work out part 2 and 3.  But answers to all parts would be appreciated.

I have a dataset with a memo field in it that contains RTF text.  I am trying to display the RTF in a grid with varying row heights depending of the size of the RTF.

I am using the grid from this link (I have attached the code at the bottom of this question)
http://www.experts-exchange.com/Programming/Languages/Pascal/Delphi/Q_23088007.html .

So in the function TLD_DBGrid.DataRowHeight I need to use something instead of DrawText that works on RTF text.  That is I need h2= height of the formatted RTF Text.  So I need to change the following lines of code.

      if Columns[ci].Field is  TMemoField
        then h2:= DrawText(Canvas.Handle,
                           pchar(Columns[ci].Field.AsString),
                           length(Columns[ci].Field.AsString),
                           r2,
                           DT_CALCRECT OR DT_WORDBREAK OR DT_NOPREFIX)

I can't use a tRichEdit because I don't have a tRichEdit (unless I create a dummy instance of tRichEdit and fudge it - but that sounds ugly).  So is there some delphi function to solve my problem or should I be calling Windows API functions?

Once I solve this question I am sure Part 2 and maybe 3 will sort themselves out.

I have attached the grid source code that I am using.
unit LD_DBGridU;
 
interface
 
uses
//  {$IFDEF VER140} DesignIntf, DesignEditors,
//{$ELSE}{$IFDEF VER150} DesignIntf, DesignEditors,
//  {$ELSE} DsgnIntf, {$ENDIF}
//  {$ENDIF}
  TypInfo, Windows, Messages, SysUtils, Classes, Grids, DBGrids, db, Controls;
 
type
  TDummyGridDataLink = class(TGridDataLink);
 
  TDrawColumnTitleEvent = procedure(ACol, ARow: Longint; ARect: TRect; AState: TGridDrawState) of object;
 
  TLD_DBGrid = class(TCustomDBGrid)
   private
    //FRowsPerLine: integer;
    FRowHeightsUpdateNeeded: Boolean;
    FOnResize: TNotifyEvent;
    FOnDrawColumnTitle: TDrawColumnTitleEvent;
    FMaxMemoLines:integer;
    function DataRowHeight: Integer;
    procedure UpdateRowHeights;
    procedure WMSize(var Message: TWMSize); message WM_SIZE;
    function RawToDataColumn(index: integer): integer;
   protected
    procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
    procedure DrawCell(ACol, ARow: Longint; ARect: TRect; AState: TGridDrawState); override;
    procedure DrawColumnCell(const Rect: TRect; DataCol: Integer;
      Column: TColumn; State: TGridDrawState); override;
    procedure RowHeightsChanged; override;
    procedure Scroll(Distance: Integer); override;
    procedure SizeChanged(OldColCount, OldRowCount: Longint); override;
    procedure Paint; Override;
   public
    constructor Create(AOwner: TComponent); override;
    function CellRect(ACol, ARow: Longint): TRect;
    procedure ForceRepaint;
    property ColumnFieldIndex[index: integer]: integer read RawToDataColumn;
    property Canvas;
    property SelectedRows;
    property EditorMode;
    property Row;
    property Col;
    property RowHeights;
    property ColWidths;
   published
    property MaxMemoLines:integer read FMaxMemoLines write FMaxMemoLines;
    property Align;
    property Anchors;
    property BiDiMode;
    property BorderStyle;
    property Color;
    property Columns stored False; //StoreColumns;
    property Constraints;
    property Ctl3D;
    property DataSource;
    property DefaultDrawing;
    property DragCursor;
    property DragKind;
    property DragMode;
    property Enabled;
    property FixedColor;
    property Font;
    property ImeMode;
    property ImeName;
    property Options;
    property ParentBiDiMode;
    property ParentColor;
    property ParentCtl3D;
    property ParentFont;
    property ParentShowHint;
    property PopupMenu;
    property ReadOnly;
    property ShowHint;
    property TabOrder;
    property TabStop;
    property TitleFont;
    property Visible;
    property OnCellClick;
    property OnColEnter;
    property OnColExit;
    property OnColumnMoved;
    property OnDrawDataCell;  { obsolete }
    property OnDrawColumnCell;
    property OnDrawColumnTitle: TDrawColumnTitleEvent read FOnDrawColumnTitle write FOnDrawColumnTitle;
    property OnDblClick;
    property OnDragDrop;
    property OnDragOver;
    property OnEditButtonClick;
    property OnEndDock;
    property OnEndDrag;
    property OnEnter;
    property OnExit;
    property OnKeyDown;
    property OnKeyPress;
    property OnKeyUp;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
    property OnResize: TNotifyEvent read FOnResize write FOnResize;
    property OnStartDock;
    property OnStartDrag;
    property OnTitleClick;
  end;
 
  procedure Register;
 
 
implementation
 
{$R *.dcr}
 
{ TLD_DBGrid }
 
function TLD_DBGrid.CellRect(ACol, ARow: Integer): TRect;
begin
  result:= inherited CellRect(ACol, ARow);
end;
 
constructor TLD_DBGrid.Create(AOwner: TComponent);
begin
  inherited;
  //DefaultDrawing := False;
  FMaxMemoLines:=4;
  FRowHeightsUpdateNeeded := True;
end;
 
function TLD_DBGrid.DataRowHeight: Integer;
var ci, h2: integer;
      r2: TRect;
begin
  result:= DefaultRowHeight;
  Canvas.Font:= self.Font;
  for ci:= 0 to Columns.Count-1 do
  begin
    if Columns[ci].Visible
    and (Columns[ci].Field<>nil)
    and (Columns[ci].Field.DataType=ftMemo) then
    begin
      r2:= classes.Rect(0, 0, Columns[ci].Width, DefaultRowHeight);
      InflateRect(r2, -2, 0); //border of 2 around text
      if Columns[ci].Field is  TMemoField
        then h2:= DrawText(Canvas.Handle,
                           pchar(Columns[ci].Field.AsString),
                           length(Columns[ci].Field.AsString),
                           r2,
                           DT_CALCRECT OR DT_WORDBREAK OR DT_NOPREFIX)
        else h2:= DrawText(Canvas.Handle,
                           pchar(Columns[ci].Field.DisplayText),
                           length(Columns[ci].Field.DisplayText),
                           r2,
                           DT_CALCRECT OR DT_WORDBREAK OR DT_NOPREFIX);
      if (result < h2)
        then result:= h2+4; //border of 2 above and below
    end;
  end;
  //Added by Justin to limit to 3 lines
  if result > ((Canvas.TextHeight('Wg') * FMaxMemoLines) +4) then
    result:=  ((Canvas.TextHeight('Wg') * FMaxMemoLines) +4);
end;
 
 
procedure TLD_DBGrid.DrawCell(ACol, ARow: Integer; ARect: TRect;
  AState: TGridDrawState);
begin
  inherited;
  if ((ARow <= FixedRows-1) AND (ACol > FixedCols-1)) AND Assigned(OnDrawColumnTitle)
//  if ((ARow = 0) AND (ACol = 0)) AND Assigned(OnDrawColumnTitle)
    then OnDrawColumnTitle(ACol, ARow, ARect, AState);
end;
 
procedure TLD_DBGrid.DrawColumnCell(const Rect: TRect; DataCol: Integer; Column: TColumn; State: TGridDrawState);
 
var r: TRect;
 
  function GetMaxHeightNeeded: integer;
  var ci, h2: integer;
      r2: TRect;
  begin
    result:= 0; //RowHeights[Row];
    for ci:= 0 to Columns.Count-1 do
    begin
      if (Columns[ci].Field<>nil) and Columns[ci].Visible then
      begin
        r2:= classes.Rect(0, 0, Columns[ci].Width, 0);// RowHeights[Row]);
        //r2.Bottom:= r2.Top;
        if Columns[ci].Field is  TMemoField
          then h2:= DrawText(Canvas.Handle,
                             pchar(Columns[ci].Field.AsString),
                             length(Columns[ci].Field.AsString),
                             r2,
                             DT_CALCRECT OR DT_WORDBREAK OR DT_NOPREFIX)
          else h2:= DrawText(Canvas.Handle,
                             pchar(Columns[ci].Field.DisplayText),
                             length(Columns[ci].Field.DisplayText),
                             r2,
                             DT_CALCRECT OR DT_WORDBREAK OR DT_NOPREFIX);
        if (result < h2)
          then result:= h2;
      end;
    end;
  end;
 
 
begin
  if (Column.Field=nil) or (Column.Field.DataType<>ftMemo) then
  begin
    inherited DrawColumnCell(Rect,DataCol,Column,State);
    exit;
  end;
 
  if DefaultDrawing then
  begin
    Canvas.FillRect(Rect);
    r:= Rect;
    InflateRect(r, -2, -2);
 
    DrawText(Canvas.Handle, PChar(Column.Field.AsString),
             Length(Column.Field.AsString), r, DT_WORDBREAK OR DT_NOPREFIX);
  end;
  if Assigned(OnDrawColumnCell) then
    OnDrawColumnCell(Self, Rect, DataCol, Column, State);
end;
 
procedure TLD_DBGrid.ForceRepaint;
begin
  FRowHeightsUpdateNeeded:=true;
  Repaint;
end;
 
procedure TLD_DBGrid.MouseDown(Button: TMouseButton; Shift: TShiftState; X,
  Y: Integer);
var
  Cell: TGridCoord;
begin
  inherited;
 
    //fix TCustomDBGrid bug: OnMouseDown event doesn't fire unless col or row < 0
    Cell := MouseCoord(X, Y);
    if (Cell.X >= 0) AND (Cell.Y >= 0) then
    begin
      if Assigned(OnMouseDown) then
      begin
        OnMouseDown(Self, Button, Shift, x, y);
        //DataSource.DataSet.MoveBy(cell.Y - row);
      end;
    end;
 
end;
 
procedure TLD_DBGrid.Paint;
begin
  if FRowHeightsUpdateNeeded
     and DataLink.Active
     and (UpdateLock = 0)
     and (LayoutLock = 0) then
  begin
    repeat
      //We need TCustomDBGrid.UpdateRowCount (private)! Work-around:
      TDummyGridDataLink(DataLink).DataSetChanged;
      RowHeightsChanged;
      UpdateRowHeights;
    until VisibleRowCount >= RowCount - FixedRows; //> due to possible multiple title
    FRowHeightsUpdateNeeded := False;
    //No inherited Paint because DataSetChanged called invalidate already
  end
  else inherited Paint;
end;
 
function TLD_DBGrid.RawToDataColumn(index: integer): integer;
begin
 
end;
 
procedure TLD_DBGrid.RowHeightsChanged;
begin
  if not FRowHeightsUpdateNeeded then inherited;
end;
 
procedure TLD_DBGrid.Scroll(Distance: Integer);
begin
  FRowHeightsUpdateNeeded := Distance <> 0;
  inherited;
  //fix bug in TCustomDBGrid:
  if (Distance > 1) or (Distance <-1) then
  begin
    //FRowHeightsUpdateNeeded := (Distance > 1) or (Distance <-1);
    ForceRepaint;
  end;
  if Distance <> 0 then SelectCell(Col, Row);
end;
 
procedure TLD_DBGrid.SizeChanged(OldColCount, OldRowCount: Integer);
begin
  FRowHeightsUpdateNeeded := True;
  inherited;
end;
 
procedure TLD_DBGrid.UpdateRowHeights;
var
  OldActiveRecord: Integer;
  iRow: Integer;
  drh:Integer;
begin
  with DataLink do begin
    OldActiveRecord := ActiveRecord;
    try
      for iRow := 0 to RowCount - 1 - FixedRows do begin
        ActiveRecord := iRow;
        drh:= DataRowHeight;
        RowHeights[iRow + FixedRows] := drh;
      end;
    finally
      ActiveRecord := OldActiveRecord;
      inherited RowHeightsChanged; //Self.RowHeightsChanged kills job
    end;
  end;
end;
 
procedure TLD_DBGrid.WMSize(var Message: TWMSize);
begin
  FRowHeightsUpdateNeeded:=true; //Added by Justin
  if Assigned(OnResize) then OnResize(self);
end;
 
procedure Register;
begin
  RegisterComponents('EnigmaS', [TLD_DBGrid]);
//  RegisterPropertyEditor(TypeInfo(TCollection), TLD_DBGrid, 'Columns',
//    TDBGridColumnsProperty);
//    TESDBGridColumnsProperty);
end;
 
end.

Open in new window

0
Comment
Question by:enigmasolutions
  • 15
  • 14
29 Comments
 
LVL 27

Expert Comment

by:kretzschmar
ID: 23598351
you already has a canvas, just set the canvas.font-properties as needed and use

h := Canvas.TextHeight('YourText');

to get the needed height for your text

you use it already

meikl ;-)

0
 
LVL 1

Author Comment

by:enigmasolutions
ID: 23606318
Thanks meikl,
That may helpd with something else I am thinking about.
I will spend some time considering this.

But, how can I get Canvas.TextHeight to work if 'Your Text' is RTF with varying fonts etc?

0
 
LVL 27

Expert Comment

by:kretzschmar
ID: 23608785
can you give me a sample of a RTF-String you have?
0
VIDEO: THE CONCERTO CLOUD FOR HEALTHCARE

Modern healthcare requires a modern cloud. View this brief video to understand how the Concerto Cloud for Healthcare can help your organization.

 
LVL 1

Author Comment

by:enigmasolutions
ID: 23608803
Thanks for getting back to me on this (much appreciated).

For now I am not using different fonts (but may do in the future).

Some sample RTF is as follows
{\rtf1\ansi\deff0{\fonttbl{\f0\fnil\fcharset0 MS Sans Serif;}{\f1\fnil MS Sans Serif;}{\f2\fnil\fcharset2 Symbol;}}
\viewkind4\uc1\pard\lang3081\f0\fs16 This is a test
\par some \b bold \b0 text
\par some \i italic  \i0 text
\par maybe some bullets
\par \pard{\pntext\f2\'B7\tab}{\*\pn\pnlvlblt\pnf2\pnindent0{\pntxtb\'B7}}\fi-200\li200 aaa
\par {\pntext\f2\'B7\tab}bbb
\par {\pntext\f2\'B7\tab}ccc
\par \pard some \ul underline \ulnone text
\par possibly different font sizes too (one day but not now)\f1 
\par }

Open in new window

0
 
LVL 1

Author Comment

by:enigmasolutions
ID: 23608819
FYI the text above should look a bit like this (except no spacing around the bullets)

This is a test
some bold text
some italic text
maybe some bullets
  • aaa
  • bbb
  • ccc
some underline text
possibly different font sizes too (one day but not now)

 
0
 
LVL 27

Expert Comment

by:kretzschmar
ID: 23608820
well, thanks, will do some tests with this sample, maybe i got a solution . . . hope it won't be an ugly one

will back soon

meikl ;-)
0
 
LVL 27

Expert Comment

by:kretzschmar
ID: 23611179
just to put a response --> no working solution yet (the one i had in mind did not work)

but still working on a solution

meikl ;-)
0
 
LVL 1

Author Comment

by:enigmasolutions
ID: 23618371
Meikl,

I really appreciate this.  I was thinking that tRichEdit uses Windows API calls to effectively draw the RTF text.  If I had the time / skills I would work out what tRichEdit did and how.

Also please send me an email with details about how we can contract you for some development work.  I don't have a lot at the moment but that could change.

Justin.
0
 
LVL 27

Expert Comment

by:kretzschmar
ID: 23619830
hi justin,

my eMail you will find in my profile (just click on my name)

following a first experimental sample (which seems to work for me)

this would be part 1, now working on part 2 (yes, there is an api for "printing" the content on a canvas, will try this)

meikl ;-)
unit calc_re_height_u;
 
interface
 
uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, ComCtrls;
 
type
  TForm1 = class(TForm)
    RichEdit1: TRichEdit;
    Button1: TButton;
    Button2: TButton;
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
  private
    function getRTFMetrics(aRTFString : String) : TPoint;
    { Private-Deklarationen }
  public
    { Public-Deklarationen }
  end;
 
var
  Form1: TForm1;
 
implementation
 
{$R *.dfm}
 
uses richedit;
 
//sample RTF
const rtfs : String = '{\rtf1\ansi\deff0{\fonttbl{\f0\fnil\fcharset0 MS Sans Serif;}{\f1\fnil MS Sans Serif;}{\f2\fnil\fcharset2 Symbol;}}'+
'\viewkind4\uc1\pard\lang3081\f0\fs16 This is a test'+
'\par some \b bold \b0 text'+
'\par some \i italic  \i0 text'+
'\par maybe some bullets'+
'\par \pard{\pntext\f2\''B7\tab}{\*\pn\pnlvlblt\pnf2\pnindent0{\pntxtb\''B7}}\fi-200\li200 aaa'+
'\par {\pntext\f2\''B7\tab}bbb'+
'\par {\pntext\f2\''B7\tab}ccc'+
'\par \pard some \ul underline \ulnone text'+
'\par possibly different font sizes too (one day but not now)\f1'+
'\par }';
 
 
//sample second RTF
const rtfs2 : String = '{\rtf1\ansi\ansicpg1252\uc1 \deff0\deflang1031\deflangfe1031{\fonttbl{\f0\froman\fcharset0\fprq2{\*\panose 02020603050405020304}Times New Roman;}{\f27\fswiss\fcharset0\fprq2{\*\panose 020b0604030504040204}Tahoma;}'+
'{\f156\fswiss\fcharset0\fprq2{\*\panose 020b0502040204020203}Segoe UI;}{\f157\froman\fcharset238\fprq2 Times New Roman CE;}{\f158\froman\fcharset204\fprq2 Times New Roman Cyr;}{\f160\froman\fcharset161\fprq2 Times New Roman Greek;}'+
'{\f161\froman\fcharset162\fprq2 Times New Roman Tur;}{\f162\froman\fcharset177\fprq2 Times New Roman (Hebrew);}{\f163\froman\fcharset178\fprq2 Times New Roman (Arabic);}{\f164\froman\fcharset186\fprq2 Times New Roman Baltic;}'+
'{\f373\fswiss\fcharset238\fprq2 Tahoma CE;}{\f374\fswiss\fcharset204\fprq2 Tahoma Cyr;}{\f376\fswiss\fcharset161\fprq2 Tahoma Greek;}{\f377\fswiss\fcharset162\fprq2 Tahoma Tur;}{\f378\fswiss\fcharset177\fprq2 Tahoma (Hebrew);}'+
'{\f379\fswiss\fcharset178\fprq2 Tahoma (Arabic);}{\f380\fswiss\fcharset186\fprq2 Tahoma Baltic;}{\f1405\fswiss\fcharset238\fprq2 Segoe UI CE;}{\f1406\fswiss\fcharset204\fprq2 Segoe UI Cyr;}{\f1408\fswiss\fcharset161\fprq2 Segoe UI Greek;}'+
'{\f1409\fswiss\fcharset162\fprq2 Segoe UI Tur;}{\f1412\fswiss\fcharset186\fprq2 Segoe UI Baltic;}}{\colortbl;\red0\green0\blue0;\red0\green0\blue255;\red0\green255\blue255;\red0\green255\blue0;\red255\green0\blue255;\red255\green0\blue0;'+
'\red255\green255\blue0;\red255\green255\blue255;\red0\green0\blue128;\red0\green128\blue128;\red0\green128\blue0;\red128\green0\blue128;\red128\green0\blue0;\red128\green128\blue0;\red128\green128\blue128;\red192\green192\blue192;}{\stylesheet{'+
'\ql \li0\ri0\widctlpar\aspalpha\aspnum\faauto\adjustright\rin0\lin0\itap0 \fs24\lang1031\langfe1031\cgrid\langnp1031\langfenp1031 \snext0 Normal;}{\*\cs10 \additive Default Paragraph Font;}}{\info{\title Dies ist ein Text mit verschiedenen Farben , }'+
'{\author Michael Kretzschmar}{\operator Michael Kretzschmar}{\creatim\yr2009\mo2\dy12\hr7\min37}{\revtim\yr2009\mo2\dy12\hr7\min39}{\version1}{\edmins0}{\nofpages1}{\nofwords0}{\nofchars0}{\*\company  .}{\nofcharsws0}{\vern8269}}'+
'\paperw11906\paperh16838\margl1417\margr1417\margt1417\margb1134 \deftab708\widowctrl\ftnbj\aenddoc\hyphhotz425\noxlattoyen\expshrtn\noultrlspc\dntblnsbdb\nospaceforul\formshade\horzdoc\dgmargin\dghspace180\dgvspace180\dghorigin1417\dgvorigin1417\dghshow1'+
'\dgvshow1\jexpand\viewkind1\viewscale100\pgbrdrhead\pgbrdrfoot\splytwnine\ftnlytwnine\htmautsp\nolnhtadjtbl\useltbaln\alntblind\lytcalctblwd\lyttblrtgr\lnbrkrule \fet0\sectd \linex0\headery708\footery708\colsx708\endnhere\sectlinegrid360\sectdefaultcl'+
'{\*\pnseclvl1\pnucrm\pnstart1\pnindent720\pnhang{\pntxta .}}{\*\pnseclvl2\pnucltr\pnstart1\pnindent720\pnhang{\pntxta .}}{\*\pnseclvl3\pndec\pnstart1\pnindent720\pnhang{\pntxta .}}{\*\pnseclvl4\pnlcltr\pnstart1\pnindent720\pnhang{\pntxta )}}{\*\pnseclvl5'+
'\pndec\pnstart1\pnindent720\pnhang{\pntxtb (}{\pntxta )}}{\*\pnseclvl6\pnlcltr\pnstart1\pnindent720\pnhang{\pntxtb (}{\pntxta )}}{\*\pnseclvl7\pnlcrm\pnstart1\pnindent720\pnhang{\pntxtb (}{\pntxta )}}{\*\pnseclvl8\pnlcltr\pnstart1\pnindent720\pnhang'+
'{\pntxtb (}{\pntxta )}}{\*\pnseclvl9\pnlcrm\pnstart1\pnindent720\pnhang{\pntxtb (}{\pntxta )}}\pard\plain \ql \li0\ri0\widctlpar\aspalpha\aspnum\faauto\adjustright\rin0\lin0\itap0 \fs24\lang1031\langfe1031\cgrid\langnp1031\langfenp1031 {'+
'Dies ist ein Text mit verschiedenen Farben ,'+
'\par }{\f156 Schriften und }{\b\f156\cf6 Gr\''f6\''dfen}{\f156 .'+
'\par }{\f27\fs40 Dies ist }{\f27\fs40\cf3 ein}{\f27\fs40  Text}{ mit verschiedenen Farben ,'+
'\par Schriften und Gr\''f6\''dfen.'+
'\par }}';
 
 
 
 
function TForm1.getRTFMetrics(aRTFString : String) : TPoint; //x = width, y = height
var
  r : TRichEdit;
  sInfo : ScrollInfo;
 
begin
  result := Point(0,0);   //result-Init
  //using a pseudo-hidden richedit to avoid a wheel-reInventing
  r := TRichEdit.Create(self);
  try
    r.Top := -1000;  //keep it out of view (avoids flicker)
    r.Left := -1000;
    r.width := 0;
    r.height := 0;
    r.parent := self;  //mus have a wincontrol-Parent
    r.Visible := true;  //must be visible for correct rendering
    r.ScrollBars := ssBoth;  //assign Scrollbars, we use they for lookup
    r.WordWrap := false;  //no wordwrap
    r.Text := aRTFString;  //assign the text
    sInfo.cbSize := SizeOf(sInfo);  //read out Scroolbar-Metrics
    sInfo.fMask := SIF_RANGE;
    GetScrollInfo(r.handle, SB_VERT, sInfo);  //for height
    //usual i thought the result is in TWips, but seemed not so
    if sInfo.nMax > 0 then
      result.Y := sInfo.nMax;
    GetScrollInfo(r.handle, SB_HORZ, sInfo);  //for width
    if sInfo.nMax > 0 then
      result.X := sInfo.nMax;
  finally
    r.Free;
  end;
end;
 
procedure TForm1.Button1Click(Sender: TObject);
var p : Tpoint;
begin
  richedit1.Text := rtfs; //using as target-Control
  p := getRTFMetrics(rtfs); //get Metrics
  //Adding some Control-Depending Offsets
  richedit1.ClientHeight := p.y + 1;
  richedit1.ClientWidth := p.x + 1;
 
end;
 
procedure TForm1.Button2Click(Sender: TObject);
var p : Tpoint;
begin
  richedit1.Text := rtfs2; //using as target-Control
  p := getRTFMetrics(rtfs2); //get Metrics
  //Adding some Control-Depending Offsets
  richedit1.ClientHeight := p.y + 1;
  richedit1.ClientWidth := p.x + 1;
end;
 
end.

Open in new window

0
 
LVL 1

Author Comment

by:enigmasolutions
ID: 23619875
Thank you.

Hmm, in the component I am working on I am only interested in the height that the RTF would occupy, because I am working on a Canvas (that comes from a Cell in a grid) and this cell has a fixed width.

So get metric really needs to just return a height.
But your code would probably work if we set r.Width = canvas.width.

What do you think?
0
 
LVL 27

Expert Comment

by:kretzschmar
ID: 23619910
well, you can simple ignore the width-result . . .
0
 
LVL 1

Author Comment

by:enigmasolutions
ID: 23619913
By the way you might want to try out the TLD_DBGrid component.  It is pretty cool when displaying a memo in a grid.  I just want to get it working with RTF.

Keep in mind the goal here is to work out whether how many lines (up to a maximum of 4) I want to resize a row in a grid to display the RTF.  Thats why I need to find out the height of the RTF within the cell in the grid.
0
 
LVL 1

Author Comment

by:enigmasolutions
ID: 23619925
Hmm, maybe but RTF will word wrap so I would need to pass in the width of the canvas to your function.  Don't you think?
0
 
LVL 1

Author Comment

by:enigmasolutions
ID: 23619978
I have to go now but I will look at this tomorrow.

Maybe modify the function as follows to get the result I am after

I will give a test tomorrow.
function TForm1.getRTFMetrics(CvWidth:integer; aRTFString : String) : Integer;
var
  r : TRichEdit;
  sInfo : ScrollInfo;
 
begin
  result := Point(0,0);   //result-Init
  //using a pseudo-hidden richedit to avoid a wheel-reInventing
  r := TRichEdit.Create(self);
  try
    r.Top := -1000;  //keep it out of view (avoids flicker)
    r.Left := -1000;
    r.width := cvWidth;
    r.height := 0;
    r.parent := self;  //mus have a wincontrol-Parent
    r.Visible := true;  //must be visible for correct rendering
    r.ScrollBars := ssVertical;  //assign Scrollbars, we use they for lookup
    r.WordWrap := true;  //wordwrap
    r.Text := aRTFString;  //assign the text
    sInfo.cbSize := SizeOf(sInfo);  //read out Scroolbar-Metrics
    sInfo.fMask := SIF_RANGE;
    GetScrollInfo(r.handle, SB_VERT, sInfo);  //for height
    //usual i thought the result is in TWips, but seemed not so
    if sInfo.nMax > 0 then
      result := sInfo.nMax;
 
    //GetScrollInfo(r.handle, SB_HORZ, sInfo);  //for width
    //if sInfo.nMax > 0 then
    //  result.X := sInfo.nMax;
  finally
    r.Free;
  end;
end;

Open in new window

0
 
LVL 1

Author Comment

by:enigmasolutions
ID: 23619994
I got a feeling that the API solution may sort out part 1 and 2.
Just the same way DrawText achieves the same result in the component.

This one is definately a challenge.

Again thanks for looking into it.
0
 
LVL 1

Author Comment

by:enigmasolutions
ID: 23620005
A trivial bit of info... I just noticed that function GetMaxHeightNeeded is not used at all and can be removed from the component.
0
 
LVL 27

Expert Comment

by:kretzschmar
ID: 23620066
hi again,
for wordwrap it should work as you changed . . .

well, will look closer into the TLD_DBGrid-class this weekend

meikl ;-)

0
 
LVL 27

Expert Comment

by:kretzschmar
ID: 23708585
?? guessed this question was solved .  .  .

what is missed?

meikl ;-)
0
 
LVL 1

Author Comment

by:enigmasolutions
ID: 23716578
No not solved.  

Meikl, I tried to send you an email.  But I guess it got lost with all the others.

I am keen to get a solution for this one.
0
 
LVL 1

Author Comment

by:enigmasolutions
ID: 23716673
Meikl,

Actually, (for PART #1) it might be ok with the code you submitted + suggestions for changes.  I just realised I forgot to test this concept.  So your answer might be ok to get the RTF Text Height.  

BUT I still need a way to draw the RTF to the canvas.
AND I think an API call would be the better option to solve all my questions above.
MAYBE you could suggest some API calls to look at.
Then again maybe I should get off my but and do it myself (so much to do, too little time).

Meikl, If you can send me an email I would be open to talking about paying you for this work.
0
 
LVL 27

Expert Comment

by:kretzschmar
ID: 23730715
well, will try a sample

btw. i sent you already an asnwer to your email . . .

meikl ;-)
0
 
LVL 1

Author Comment

by:enigmasolutions
ID: 23730825
Meikl,

Thanks - looking forward to seeing your sample.

I didn't get your email (maybe my spam filter is too restrictive). Anyway could you re-send the email AND cc my
(Mail address removed
kretzschmar
PE Delphi)
 (with two underscores). Thanks.
0
 
LVL 27

Expert Comment

by:kretzschmar
ID: 23730963
well, sent
0
 
LVL 27

Accepted Solution

by:
kretzschmar earned 2000 total points
ID: 23753976
Hi Justin,

got it, to code an experimental sample (which works just fine)

introduced new is

getRTFHeight --> gets the Height depanding on the Width
rtfPrint --> Prints the Content to any Canvas

usage TestCase in the DrawCellEvent of a StringGrid

Tell me your thoughts

meikl ;-)

unit calc_re_height_u;
 
interface
 
uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, ComCtrls, Grids;
 
type
  TForm1 = class(TForm)
    RichEdit1: TRichEdit;
    Button1: TButton;
    Button2: TButton;
    StringGrid1: TStringGrid;
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure Button3Click(Sender: TObject);
    procedure StringGrid1DrawCell(Sender: TObject; ACol, ARow: Integer;
      Rect: TRect; State: TGridDrawState);
  private
    function getRTFMetrics(aRTFString : String) : TPoint;
    function getRTFHeight(aRTFString : String; aWidth : Integer) : Integer;
    procedure rtfPrint(aRTFString : String; aRect : TRect; aCanvas : TCanvas);
    { Private-Deklarationen }
  public
    { Public-Deklarationen }
  end;
 
var
  Form1: TForm1;
 
implementation
 
{$R *.dfm}
 
uses richedit;
 
//sample RTF
const rtfs : String = '{\rtf1\ansi\deff0{\fonttbl{\f0\fnil\fcharset0 MS Sans Serif;}{\f1\fnil MS Sans Serif;}{\f2\fnil\fcharset2 Symbol;}}'+
'\viewkind4\uc1\pard\lang3081\f0\fs16 This is a test'+
'\par some \b bold \b0 text'+
'\par some \i italic  \i0 text'+
'\par maybe some bullets'+
'\par \pard{\pntext\f2\''B7\tab}{\*\pn\pnlvlblt\pnf2\pnindent0{\pntxtb\''B7}}\fi-200\li200 aaa'+
'\par {\pntext\f2\''B7\tab}bbb'+
'\par {\pntext\f2\''B7\tab}ccc'+
'\par \pard some \ul underline \ulnone text'+
'\par possibly different font sizes too (one day but not now)\f1'+
'\par }';
 
 
//sample second RTF
const rtfs2 : String = '{\rtf1\ansi\ansicpg1252\uc1 \deff0\deflang1031\deflangfe1031{\fonttbl{\f0\froman\fcharset0\fprq2{\*\panose 02020603050405020304}Times New Roman;}{\f27\fswiss\fcharset0\fprq2{\*\panose 020b0604030504040204}Tahoma;}'+
'{\f156\fswiss\fcharset0\fprq2{\*\panose 020b0502040204020203}Segoe UI;}{\f157\froman\fcharset238\fprq2 Times New Roman CE;}{\f158\froman\fcharset204\fprq2 Times New Roman Cyr;}{\f160\froman\fcharset161\fprq2 Times New Roman Greek;}'+
'{\f161\froman\fcharset162\fprq2 Times New Roman Tur;}{\f162\froman\fcharset177\fprq2 Times New Roman (Hebrew);}{\f163\froman\fcharset178\fprq2 Times New Roman (Arabic);}{\f164\froman\fcharset186\fprq2 Times New Roman Baltic;}'+
'{\f373\fswiss\fcharset238\fprq2 Tahoma CE;}{\f374\fswiss\fcharset204\fprq2 Tahoma Cyr;}{\f376\fswiss\fcharset161\fprq2 Tahoma Greek;}{\f377\fswiss\fcharset162\fprq2 Tahoma Tur;}{\f378\fswiss\fcharset177\fprq2 Tahoma (Hebrew);}'+
'{\f379\fswiss\fcharset178\fprq2 Tahoma (Arabic);}{\f380\fswiss\fcharset186\fprq2 Tahoma Baltic;}{\f1405\fswiss\fcharset238\fprq2 Segoe UI CE;}{\f1406\fswiss\fcharset204\fprq2 Segoe UI Cyr;}{\f1408\fswiss\fcharset161\fprq2 Segoe UI Greek;}'+
'{\f1409\fswiss\fcharset162\fprq2 Segoe UI Tur;}{\f1412\fswiss\fcharset186\fprq2 Segoe UI Baltic;}}{\colortbl;\red0\green0\blue0;\red0\green0\blue255;\red0\green255\blue255;\red0\green255\blue0;\red255\green0\blue255;\red255\green0\blue0;'+
'\red255\green255\blue0;\red255\green255\blue255;\red0\green0\blue128;\red0\green128\blue128;\red0\green128\blue0;\red128\green0\blue128;\red128\green0\blue0;\red128\green128\blue0;\red128\green128\blue128;\red192\green192\blue192;}{\stylesheet{'+
'\ql \li0\ri0\widctlpar\aspalpha\aspnum\faauto\adjustright\rin0\lin0\itap0 \fs24\lang1031\langfe1031\cgrid\langnp1031\langfenp1031 \snext0 Normal;}{\*\cs10 \additive Default Paragraph Font;}}{\info{\title Dies ist ein Text mit verschiedenen Farben , }'+
'{\author Michael Kretzschmar}{\operator Michael Kretzschmar}{\creatim\yr2009\mo2\dy12\hr7\min37}{\revtim\yr2009\mo2\dy12\hr7\min39}{\version1}{\edmins0}{\nofpages1}{\nofwords0}{\nofchars0}{\*\company  .}{\nofcharsws0}{\vern8269}}'+
'\paperw11906\paperh16838\margl1417\margr1417\margt1417\margb1134 \deftab708\widowctrl\ftnbj\aenddoc\hyphhotz425\noxlattoyen\expshrtn\noultrlspc\dntblnsbdb\nospaceforul\formshade\horzdoc\dgmargin\dghspace180\dgvspace180\dghorigin1417\dgvorigin1417\dghshow1'+
'\dgvshow1\jexpand\viewkind1\viewscale100\pgbrdrhead\pgbrdrfoot\splytwnine\ftnlytwnine\htmautsp\nolnhtadjtbl\useltbaln\alntblind\lytcalctblwd\lyttblrtgr\lnbrkrule \fet0\sectd \linex0\headery708\footery708\colsx708\endnhere\sectlinegrid360\sectdefaultcl'+
'{\*\pnseclvl1\pnucrm\pnstart1\pnindent720\pnhang{\pntxta .}}{\*\pnseclvl2\pnucltr\pnstart1\pnindent720\pnhang{\pntxta .}}{\*\pnseclvl3\pndec\pnstart1\pnindent720\pnhang{\pntxta .}}{\*\pnseclvl4\pnlcltr\pnstart1\pnindent720\pnhang{\pntxta )}}{\*\pnseclvl5'+
'\pndec\pnstart1\pnindent720\pnhang{\pntxtb (}{\pntxta )}}{\*\pnseclvl6\pnlcltr\pnstart1\pnindent720\pnhang{\pntxtb (}{\pntxta )}}{\*\pnseclvl7\pnlcrm\pnstart1\pnindent720\pnhang{\pntxtb (}{\pntxta )}}{\*\pnseclvl8\pnlcltr\pnstart1\pnindent720\pnhang'+
'{\pntxtb (}{\pntxta )}}{\*\pnseclvl9\pnlcrm\pnstart1\pnindent720\pnhang{\pntxtb (}{\pntxta )}}\pard\plain \ql \li0\ri0\widctlpar\aspalpha\aspnum\faauto\adjustright\rin0\lin0\itap0 \fs24\lang1031\langfe1031\cgrid\langnp1031\langfenp1031 {'+
'Dies ist ein Text mit verschiedenen Farben ,'+
'\par }{\f156 Schriften und }{\b\f156\cf6 Gr\''f6\''dfen}{\f156 .'+
'\par }{\f27\fs40 Dies ist }{\f27\fs40\cf3 ein}{\f27\fs40  Text}{ mit verschiedenen Farben ,'+
'\par Schriften und Gr\''f6\''dfen.'+
'\par }}';
 
 
//<-- older Functions
function TForm1.getRTFMetrics(aRTFString : String) : TPoint; //x = width, y = height
var
  r : TRichEdit;
  sInfo : ScrollInfo;
 
begin
  result := Point(0,0);   //result-Init
  //using a pseudo-hidden richedit to avoid a wheel-reInventing
  r := TRichEdit.Create(self);
  try
    r.Top := -1000;  //keep it out of view (avoids flicker)
    r.Left := -1000;
    r.width := 0;
    r.height := 0;
    r.parent := self;  //mus have a wincontrol-Parent
    r.Visible := true;  //must be visible for correct rendering
    r.ScrollBars := ssBoth;  //assign Scrollbars, we use they for lookup
    r.WordWrap := false;  //no wordwrap
    r.Text := aRTFString;  //assign the text
    sInfo.cbSize := SizeOf(sInfo);  //read out Scroolbar-Metrics
    sInfo.fMask := SIF_RANGE;
    GetScrollInfo(r.handle, SB_VERT, sInfo);  //for height
    //usual i thought the result is in TWips, but seemed not so
    if sInfo.nMax > 0 then
      result.Y := sInfo.nMax;
    GetScrollInfo(r.handle, SB_HORZ, sInfo);  //for width
    if sInfo.nMax > 0 then
      result.X := sInfo.nMax;
  finally
    r.Free;
  end;
end;
 
 
procedure TForm1.Button1Click(Sender: TObject);
var p : Tpoint;
begin
  richedit1.Text := rtfs; //using as target-Control
  p := getRTFMetrics(rtfs); //get Metrics
  //Adding some Control-Depending Offsets
  richedit1.ClientHeight := p.y + 1;
  richedit1.ClientWidth := p.x + 1;
 
end;
 
procedure TForm1.Button2Click(Sender: TObject);
var p : Tpoint;
begin
  richedit1.Text := rtfs2; //using as target-Control
  p := getRTFMetrics(rtfs2); //get Metrics
  //Adding some Control-Depending Offsets
  richedit1.ClientHeight := p.y + 1;
  richedit1.ClientWidth := p.x + 1;
end;
 
 
 
procedure TForm1.Button3Click(Sender: TObject);
begin
end;
 
//<---- GridHandling
 
 
//Get Height, Depending on Width
function TForm1.getRTFHeight(aRTFString : String; aWidth : Integer) : Integer; //Returns the height
var
  r : TRichEdit;
  sInfo : ScrollInfo;
begin
  result := 0;   //result-Init
  //using a pseudo-hidden richedit to avoid a wheel-reInventing
  r := TRichEdit.Create(self);
  try
    r.Top := -1000;  //keep it out of view (avoids flicker)
    r.Left := -1000;
    r.width := aWidth;
    r.height := 0;
    r.parent := self;  //mus have a wincontrol-Parent
    r.Visible := true;  //must be visible for correct rendering
    r.ScrollBars := ssVertical;  //assign Scrollbars, we use they for lookup
    r.WordWrap := true;  //no wordwrap
    r.Text := aRTFString;  //assign the text
    sInfo.cbSize := SizeOf(sInfo);  //read out Scrollbar-Metrics
    sInfo.fMask := SIF_RANGE;
    GetScrollInfo(r.handle, SB_VERT, sInfo);  //for height
    //usual i thought the result is in TWips, but seemed not so
    if sInfo.nMax > 0 then
      result := sInfo.nMax;
  finally
    r.Free;
  end;
end;
 
//Render to any given Canvas
procedure TForm1.rtfPrint(aRTFString : String; aRect : TRect; aCanvas : TCanvas);
var
  r : TRichEdit;
  fr : TFormatRange;
  cr : TCharRange;
begin
  //using a pseudo-hidden richedit to avoid a wheel-reInventing
  r := TRichEdit.Create(self);
  try
    r.Top := -1000;  //keep it out of view (avoids flicker)
    r.Left := -1000;
    r.width := aRect.Right-aRect.Left;
    r.height := aRect.Bottom-aRect.Top;
    r.parent := self;  //mus have a wincontrol-Parent
    r.Visible := true;  //must be visible for correct rendering
    r.ScrollBars := ssNone;  //assign no Scrollbars
    r.WordWrap := true;  // wordwrap
    r.Text := aRTFString;  //assign the text
 
    FillChar(fr, SizeOf(fr), 0);
   // Rendering
    fr.hdc        := aCanvas.handle;
    fr.hdcTarget  := aCanvas.Handle;
 
   // Setup PaintingRect in TWips
   fr.rc.left    := aRect.Left  * 1440 div Screen.PixelsPerInch;
   fr.rc.top     := aRect.top  * 1440 div Screen.PixelsPerInch;
   fr.rc.right   := aRect.Right * 1440 div Screen.PixelsPerInch;
   fr.rc.Bottom  := aRect.Bottom * 1440 div Screen.PixelsPerInch;
 
   // Whole Richedit
   fr.chrg.cpMax := -1;
   fr.chrg.cpMin := 0;
 
   // Render
   SendMessage(r.Handle, EM_FORMATRANGE, 1, Longint(@fr));
 
   // Release
   SendMessage(r.handle, EM_FORMATRANGE, 0,0);
 
  finally
    r.Free;
  end;
end;
 
 
//Testing on a StringGrid on the DrawCellEvent (goColSizing in Options is set to True)
procedure TForm1.StringGrid1DrawCell(Sender: TObject; ACol, ARow: Integer;
  Rect: TRect; State: TGridDrawState);
begin
  If (ACol = 1) and (ARow = 1) then
  begin
    stringgrid1.RowHeights[ARow] := getRTFHeight(rtfs2, stringgrid1.ColWidths[ACol]); //get Metrics
    rtfPrint(rtfs2,Rect,stringgrid1.Canvas);
  end;
 
  If (ACol = 1) and (ARow = 2) then
  begin
    stringgrid1.RowHeights[ARow] := getRTFHeight(rtfs, stringgrid1.ColWidths[ACol]); //get Metrics
    rtfPrint(rtfs,Rect,stringgrid1.Canvas);
  end;
end;
 
end.

Open in new window

0
 
LVL 27

Expert Comment

by:kretzschmar
ID: 23754013
btw. next step is the build into your grid-component . . .
0
 
LVL 1

Author Comment

by:enigmasolutions
ID: 23754024
Yes I can do that.  And I will post the final component here when done.  I have to go now but will do this early next week.

Your solution is VERY SNEAKY but I like it.

I was kind of hoping for an API solution.  I can't help thinking that there must be a couple of API functions that will do the job for me.  Anyway, I am going to accept your answer, which is a pretty cool work around.

I will give it a go early next week.

Thanks for you help.
0
 
LVL 1

Author Closing Comment

by:enigmasolutions
ID: 31544408
Great Job Meikl!
0
 
LVL 27

Expert Comment

by:kretzschmar
ID: 23754088
well, of course, optimations are possible
for ex. getHeight and print in one step

i also searched for an api-solution, but all the sample and documents i reviewed pointing out to create a richtext-control before . . . whereas i, instead to create one via api, used the vcl-richedit-control

keep us in contact and if you struggles, just force me to help

meikl ;-)
0
 
LVL 27

Expert Comment

by:kretzschmar
ID: 23754092
btw. Part III should be easy now
0

Featured Post

Important Lessons on Recovering from Petya

In their most recent webinar, Skyport Systems explores ways to isolate and protect critical databases to keep the core of your company safe from harm.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

In our object-oriented world the class is a minimal unit, a brick for constructing our applications. It is an abstraction and we know well how to use it. In well-designed software we are not usually interested in knowing how objects look in memory. …
Introduction I have seen many questions in this Delphi topic area where queries in threads are needed or suggested. I know bumped into a similar need. This article will address some of the concepts when dealing with a multithreaded delphi database…
This tutorial covers a step-by-step guide to install VisualVM launcher in eclipse.
The viewer will learn how to use and create new code templates in NetBeans IDE 8.0 for Windows.
Suggested Courses
Course of the Month13 days, 20 hours left to enroll

807 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question