5

我正在尝试在 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 像素高的矩形。

我打开了自动换行，尽管我的印象是不需要这样做。

有任何想法吗？

4

1 回答 1

6

您的单位已关闭。从您的代码中考虑这个表达式，例如：

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;
于 2011-10-13T15:20:02.110 回答