Обрезка текста при отрисовке на канве

[The_Immortal]

Приветствую!

Имеется задача отрисовывать текст по выбранному шрифту на Image в определенном формате. При этом текст сразу отрисовываться сразу одной строкой не может, т.к. элементы строки содержат разный цвет, поэтому отрисовка текста происходит в цикле со смещением вправо.
Проблема возникает в том, что на выходе текст обрезается, т.к. по каким-то причинам некорректно рассчитывается его ширина. Особенно это проглядывается при выборе курсива - там вообще ширина получается идентичной, что и без курсива почему-то. Но и без курсива проблема имеется.

Упрощенный пример задачи:

procedure TForm2.Button1Click(Sender: TObject);
var
  i, WidthShift: Integer;
  str, delim: string;
  Font: TFont;
  Colors: TArray<TColor>;

begin
  Font := TFont.Create;
  Colors := TArray<TColor>.Create(clRed, clBlack, clGreen);
  WidthShift := 10;

  if FontDialog1.Execute then
  begin
    Font.Assign(FontDialog1.Font);
  end;

  Image1.Canvas.Brush.Color := clWhite;
  Image1.Canvas.FillRect(Image1.Canvas.ClipRect);

  Image1.Canvas.Font.Assign(Font);
  delim := '/';

  for i := 0 to 2 do
  begin
    str := '0';
    if i <> 0 then
      str := delim + str;
    Image1.Canvas.Font.Color := Colors[i];
    Image1.Canvas.TextOut(WidthShift, 100, str);
    WidthShift := WidthShift + Image1.Canvas.TextWidth(str);
  end;
  Font.Free;
end;

Ниже результат. В первом случае текст обычный и все равно обрезается. А во втором курсив - там вообще все плохо.
В качестве решения можно было бы рассчитывать какой-то промежуточный запас (относительно высоты шрифта или еще по какой-то зависимости) и добавлять его на каждой итерации, однако по условиям задачи пробелов быть не должно.

Подскажите, пожалуйста, как можно поборот данную проблему?

Спасибо!

[DIONISKA]

Не текст обрезается, а просто фон текстовой области накладывается на соседнюю букву, используйте кисть со стилем bsclear при отрисовке текста и не нужны будут костыли

//...
  Image1.Canvas.Brush.Style:=bsSolid;
  Image1.Canvas.Brush.Color := clWhite;
  Image1.Canvas.FillRect(Image1.Canvas.ClipRect);
  Image1.Canvas.Font.Assign(Font);
  Image1.Canvas.Brush.Style:=bsClear;
//..
  delim := '/';

[The_Immortal]

DIONISKA, забыл еще уточнить, что мне необходима белая подложка, т.к. текст этот отрисовывается на фоне других цветных элементов (того же цвета, что и сам текст), поэтому его надо выделять через белую подложку, соответственно bsclear использовать не могу...

[DIONISKA]

Сообщение от The_Immortal

мне необходима белая подложка

вы же читали код выше? белый прямоугольник отрисовывается в самом начале, заливка области сплошной кистью белым цветом (bsSolid):

Image1.Canvas.Brush.Style:=bsSolid;
  Image1.Canvas.Brush.Color := clWhite;
  Image1.Canvas.FillRect(Image1.Canvas.ClipRect);

а затем меняете тип кисти на bsClear и отрисовываете текст. Опционально после отрисовки текста можно вернуть стиль кисти bsSolid. Вам-же так надо?

[The_Immortal]

DIONISKA, я, вероятно, некорректно изъясняюсь.
Мне необходимо, чтобы фон самого текста был на белом фоне.

В примере ниже фон изображения не белый (например, черный) и средний черный '0' может быть виден только с не черной (например, белой) подложкой. Мне необходимо, чтобы текст выводился с белым фоном, т.к. на заднем плане (общий закраска Image) может быть любой цвет, но не белый. Именно по этим причинам:

Сообщение от The_Immortal

bsclear использовать не могу...

[BDA]

The_Immortal, если с bsclear кистью текст не обрезается, то просто добавьте отрисовку белого прямоугольника-фона для текста перед выводом текста, что и предлагает DIONISKA.

[The_Immortal]

BDA, я не врубаюсь как это сделать...
Пробовал вот так. Все равно обрезается.

Где я косячу?

[BDA]

Можно, например, вывести весь текст белым цветом на белом фоне, а потом уже нужным цветом на прозрачном:

begin
  Font := TFont.Create;
  Colors := TArray<TColor>.Create(clRed, clBlack, clGreen);
  WidthShift := 10;

  if FontDialog1.Execute then
  begin
    Font.Assign(FontDialog1.Font);
  end;

  Image1.Canvas.Brush.Style := bsSolid;
  Image1.Canvas.Brush.Color := clBlack;
  Image1.Canvas.FillRect(Image1.Canvas.ClipRect);
  Image1.Canvas.Font.Assign(Font);

  Image1.Canvas.Brush.Color := clWhite;
  Image1.Canvas.Font.Color := clWhite;
  Image1.Canvas.TextOut(WidthShift, 100, '0/0/0');

  Image1.Canvas.Brush.Style := bsClear;
  delim := '/';

  for i := 0 to 2 do
  begin
    str := '0';
    if i <> 0 then
      str := delim + str;
    Image1.Canvas.Font.Color := Colors[i];
    Image1.Canvas.TextOut(WidthShift, 100, str);
    WidthShift := WidthShift + Image1.Canvas.TextWidth(str);
  end;
  Font.Free;
end;

[DIONISKA]

Странная у вас конечно задача..
Тут если подумать есть минмум 4 решения:
1. Просто отисовать текст дважды: первый с заливкой, второй без заливки - это самый простой и быстрый костыль.
2. Отрисовывать текст с последней буквы и до первой в обратном порядке, но тут может что-то пойти не так на italic/bold italic шрифтах с наклоном в обратную сторону или шрифтах с завитушками
3. Отрисовывать где-нибудь отдельно, например на отдельном битмапе, а потом уже его рисовать на вашем Image1.Canvas, можно также с задействованием blend-функций, и тп
4. Как предлагал ранее товарищ BDA: сначала подсчитать размеры всего текста (с помощью TextWidth/TextHeight/TextRect), нарисовать прямоугольник, а потом уже поверх отрисовывать текст.

Сообщение от The_Immortal

Все равно обрезается.

А не получается у вас потому, что нужно сначала посчитать размеры текстовой области, затем нарисовать прямоугольник, а потом уже в цикле рисовать текст с bsclear.
Собственно почему происходит такой эффект? Потому что когда вы посимвольно выводите/получаете размеры текста, то область, в которую вписывается каждая буква перекрывает область предыдущей и опционально следующей(у рукописных шрифтов, с завитушками и тп) буквы, а если эту область залить, то она закрасит часть окружающих букв.
PS: если ограничиться моноширными шрифтами, то эта проблема не возникнет

[The_Immortal]

DIONISKA,

Сообщение от DIONISKA

4. Как предлагал ранее товарищ BDA: сначала подсчитать размеры всего текста (с помощью TextWidth/TextHeight/TextRect), нарисовать прямоугольник, а потом уже поверх отрисовывать текст

Полагаю, что этот вариант ничем по сути не отличается от варианта № 1 - надо заранее знать всю строку текста, так?

Сообщение от DIONISKA

3. Отрисовывать где-нибудь отдельно, например на отдельном битмапе, а потом уже его рисовать на вашем Image1.Canvas, можно также с задействованием blend-функций, и тп

А можно попросить какой-нибудь мини-пример? Плохо понимаю как его реализовать в своей задаче и как это решит проблему?

Сообщение от DIONISKA

Собственно почему происходит такой эффект? Потому что когда вы посимвольно выводите/получаете размеры текста, то область, в которую вписывается каждая буква перекрывает область предыдущей и опционально следующей(у рукописных шрифтов, с завитушками и тп) буквы, а если эту область залить, то она закрасит часть окружающих букв.

Так вопрос почему именно так происходит? Я так понимаю это связано с тем, что ширина текста что курсивом, что обычным - идентична, т.е. в случае курсива она определяется некорректно. И из-за этого и возникают перекрывания. Так ведь?