将 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

左侧项以像素为单位，右侧项以像素/英寸为单位，因此结果的单位为像素平方/英寸。 em_FormatRange 中使用的矩形的预期单位是缇。如果您想将像素转换为缇，您需要这个：

const
  TwipsPerInch = 1440;

RichText.Width / Screen.PixelsPerInch * TwipsPerInch

---

您不需要屏幕外的丰富编辑控件。您只需要一个无窗口丰富编辑控件，您可以指示将其直接绘制到工具提示上。 我发布了一些 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;