将TRichEdit画到画布上

Question

我试图在Delphi XE中实现一个支持RTF的工具提示窗口。为了呈现富文本，我使用屏幕外的TRichEdit。我需要做两件事：

1. 测量文本的大小。
2. 画文字

为了完成这两项任务，我编写了以下方法：

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;

Range参数被传入，因此我可以在此方法之外使用计算出的维度。MustPaint参数确定是否应该计算范围(False)或绘制范围(True)。

要计算范围，我将此方法称为：

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;

来画它：

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

问题是，当它计算一个438像素宽和212像素高的矩形时，它实际上画了一个非常宽的矩形(剪裁)，只有52像素高。

我打开了包装，虽然我的印象是，这不应该是必要的。

有什么想法吗？

Answer 1

你的单位关机了。请考虑代码中的这个表达式，例如：

RichText.Width * Screen.Pixelsperinch

左项以像素为单位，右项以像素/英寸为单位，因此结果的单位为像素2/英寸。em_FormatRange中使用的矩形的预期单位是twips。如果要将像素转换为twips，则需要以下内容：

const
  TwipsPerInch = 1440;

RichText.Width / Screen.PixelsPerInch * TwipsPerInch

您不需要一个屏幕外的富编辑控件。你只需要一个http://msdn.microsoft.com/en-us/library/windows/desktop/bb787609.aspx，你可以指示它直接画在你的工具尖上。我已经发布了一些Delphi代码，使基本知识变得简单明了。注意它不支持Unicode，我也没有计划这么做(尽管它可能不会太复杂)。

我的代码中的主要函数是DrawRTF，如下所示，在RTFPaint.pas中。但是，它并不完全适合您的需要；您希望在绘制它之前发现它的大小，而我的代码假设您已经知道了绘图目标的尺寸。若要度量RTF文本的大小，请调用ITextServices.TxGetNaturalSize。

词的包装很重要。如果没有它，控件将假设它有无限的宽度可供使用，并且它将只在RTF文本请求时启动一个新行。

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;