Painting TRichEdit to a canvas

I'm trying to implement an RTF-capable tool tip window in Delphi XE. To render the rich text, I'm using an off-screen TRichEdit. I need to do two things:

1. Measure the size of the text.
2. Paint the text

To accomplish both tasks, I wrote this method:

procedure TLookupHintWindow.CallFormatRange(R: TRect; var Range: TFormatRange;
  MustPaint: Boolean);
var
  TextRect: TRect;
begin
  RichText.SetBounds(R.Left, R.Top, R.Right, R.Bottom);
  TextRect := Rect(0, 0,
    RichText.Width * Screen.Pixelsperinch,
    RichText.Height * Screen.Pixelsperinch);

  ZeroMemory(@Range, SizeOf(Range));
  Range.hdc := Canvas.Handle;
  Range.hdcTarget := Canvas.Handle;
  Range.rc := TextRect;
  Range.rcpage := TextRect;
  Range.chrg.cpMin := 0;
  Range.chrg.cpMax := -1;

  SendMessage(RichText.Handle, EM_FORMATRANGE,
    NativeInt(MustPaint), NativeInt(@Range));
  SendMessage(RichText.Handle, EM_FORMATRANGE, 0, 0);
end;

The Range parameter is passed in, so I can use the calculated dimensions outside this method. The MustPaint parameter determines if the range should be calculated (False) or painted (True).

To calculate the range, I call this method:

function TLookupHintWindow.CalcRichTextRect(R: TRect; const Rtf: string): TRect;
var
  Range: TFormatRange;
begin
  LoadRichText(Rtf);

  CallFormatRange(R, Range, False);

  Result := Range.rcpage;
  Result.Right := Result.Right div Screen.PixelsPerInch;
  Result.Bottom := Result.Bottom div Screen.PixelsPerInch;
  // In my example yields this rect: (0, 0, 438, 212)
end;

To paint it:

procedure TLookupHintWindow.DrawRichText(const Text: string; R: TRect);
var
  Range: TFormatRange;
begin
  CallFormatRange(R, Range, True);
end;

The problem is that while it calculates a rectangle that is 438 pixe开发者_运维问答ls wide and 212 high, it actually paints one that is very wide (gets clipped) and only 52 pixels high.

I have word wrap turned on, although it was my impression that that should not be needed.

Any ideas?

Your units are off. Consider this expression from your code, for example:

RichText.Width * Screen.Pixelsperinch

The left term is in pixels, and the right term is in pixels/inch, so the units of the result are pixels²/inch. The expected unit for the rectangles used in em_FormatRange is twips. If you want to convert pixels to twips, you need this:

const
  TwipsPerInch = 1440;

RichText.Width / Screen.PixelsPerInch * TwipsPerInch

You don't need an off-screen rich-edit control. You just need a windowless rich-edit control, which you can instruct to paint directly onto your tool-tip. I've published some Delphi code that makes the basics straightforward. Beware that it's not Unicode-aware, and I have no plans to make it so (although it might not be too complicated to do).

The main function from my code is DrawRTF, shown below, in RTFPaint.pas. It doesn't quite fit your needs, though; you want to discover the size before drawing it, whereas my code assume you already know the dimensions of the drawing target. To measure the size of the RTF text, call ITextServices.TxGetNaturalSize.

Word wrapping is important. Without it, the control will assume it has infinite width to work with, and it will only start a new line when the RTF text requests it.

procedure DrawRTF(Canvas: TCanvas; const RTF: string; const Rect: TRect;
  const Transparent, WordWrap: Boolean);
var
  Host: ITextHost;
  Unknown: IUnknown;
  Services: ITextServices;
  HostImpl: TTextHostImpl;
  Stream: TEditStream;
  Cookie: TCookie;
  res: Integer;
begin
  HostImpl := TDrawRTFTextHost.Create(Rect, Transparent, WordWrap);
  Host := CreateTextHost(HostImpl);
  OleCheck(CreateTextServices(nil, Host, Unknown));
  Services := Unknown as ITextServices;
  Unknown := nil;
  PatchTextServices(Services);

  Cookie.dwCount := 0;
  Cookie.dwSize := Length(RTF);
  Cookie.Text := PChar(RTF);
  Stream.dwCookie := Integer(@Cookie);
  Stream.dwError := 0;
  Stream.pfnCallback := EditStreamInCallback;
  OleCheck(Services.TxSendMessage(em_StreamIn, sf_RTF or sff_PlainRTF,
    lParam(@Stream), res));

  OleCheck(Services.TxDraw(dvAspect_Content, 0, nil, nil, Canvas.Handle,
    0, Rect, PRect(nil)^, PRect(nil)^, nil, 0, txtView_Inactive));
  Services := nil;
  Host := nil;
end;