RTF Text Height

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

LVL 1
enigmasolutionsAsked:
Who is Participating?
 
kretzschmarConnect With a Mentor Commented:
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
 
kretzschmarCommented:
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
 
enigmasolutionsAuthor Commented:
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
Cloud Class® Course: Python 3 Fundamentals

This course will teach participants about installing and configuring Python, syntax, importing, statements, types, strings, booleans, files, lists, tuples, comprehensions, functions, and classes.

 
kretzschmarCommented:
can you give me a sample of a RTF-String you have?
0
 
enigmasolutionsAuthor Commented:
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
 
enigmasolutionsAuthor Commented:
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
 
kretzschmarCommented:
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
 
kretzschmarCommented:
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
 
enigmasolutionsAuthor Commented:
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
 
kretzschmarCommented:
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
 
enigmasolutionsAuthor Commented:
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
 
kretzschmarCommented:
well, you can simple ignore the width-result . . .
0
 
enigmasolutionsAuthor Commented:
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
 
enigmasolutionsAuthor Commented:
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
 
enigmasolutionsAuthor Commented:
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
 
enigmasolutionsAuthor Commented:
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
 
enigmasolutionsAuthor Commented:
A trivial bit of info... I just noticed that function GetMaxHeightNeeded is not used at all and can be removed from the component.
0
 
kretzschmarCommented:
hi again,
for wordwrap it should work as you changed . . .

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

meikl ;-)

0
 
kretzschmarCommented:
?? guessed this question was solved .  .  .

what is missed?

meikl ;-)
0
 
enigmasolutionsAuthor Commented:
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
 
enigmasolutionsAuthor Commented:
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
 
kretzschmarCommented:
well, will try a sample

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

meikl ;-)
0
 
enigmasolutionsAuthor Commented:
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
 
kretzschmarCommented:
well, sent
0
 
kretzschmarCommented:
btw. next step is the build into your grid-component . . .
0
 
enigmasolutionsAuthor Commented:
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
 
enigmasolutionsAuthor Commented:
Great Job Meikl!
0
 
kretzschmarCommented:
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
 
kretzschmarCommented:
btw. Part III should be easy now
0
Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

All Courses

From novice to tech pro — start learning today.