Живопись TRichEdit на холсте - PullRequest
Новая
       26

Живопись TRichEdit на холсте

4 голосов
/ 13 октября 2011

Я пытаюсь реализовать окно подсказки с поддержкой RTF в Delphi XE.Для рендеринга расширенного текста я использую закадровый 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 пикселя.

Iвключить перенос слов, хотя у меня сложилось впечатление, что в этом нет необходимости.

Есть идеи?

1 Ответ

5 голосов
/ 13 октября 2011

Ваши юниты выключены. Рассмотрим это выражение из вашего кода, например: 

RichText.Width * Screen.Pixelsperinch

Левый член указан в пикселях, а правый - в пикселях / дюйм, поэтому в качестве единиц результата используются пиксели² / дюйм. Ожидаемая единица измерения для прямоугольников, используемых в em_FormatRange, - это двойки. Если вы хотите конвертировать пиксели в твипы, вам нужно: 

const
  TwipsPerInch = 1440;

RichText.Width / Screen.PixelsPerInch * TwipsPerInch

Вам не нужен закадровый элемент управления rich-edit. Вам просто необходим элемент управления rich-edit без окон , который вы можете настроить для рисования прямо на подсказке. Я опубликовал некоторый код 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;
...