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

[DIONISKA]

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

Полагаю, что этот вариант ничем по сути не отличается от варианта № 1

Результат или процесс? в 1-м случае нужно просто отрисовать текст с заполнением фона и второй раз без. 4-й вариант рассчитать размеры текстовой области, залить эту область и выводить текст со стилем кисти bsclear. Для первого случая ваш изначальный вариант претерпит минимум изменений, собственно это самый лёгкий способ:

procedure TForm1.Button1Click(Sender: TObject);
var
  str, delim: string;
  Font: TFont;
  Colors: TArray<TColor>;
  procedure drawmytext(); //повторяющяася часть вынесена в процедуру
  var
    WidthShift,i:Integer;
    begin
    WidthShift := 10;
     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;
    end;
begin
  Font := TFont.Create;
  Colors := TArray<TColor>.Create(clRed, clBlack, clGreen);
  if FontDialog1.Execute then
  begin
    Font.Assign(FontDialog1.Font);
  end;
  Image1.Canvas.Brush.style:=bssolid;
  Image1.Canvas.Brush.Color := clWhite;
  Image1.Canvas.FillRect(Image1.Canvas.ClipRect);
  Image1.Canvas.Font.Assign(Font);
  delim := '/';
  drawmytext; //рисуем текст с непрозрачным заполнением
  Image1.Canvas.Brush.style:=bsClear;
  drawmytext; // теперь с bsclear
  Image1.Canvas.Brush.style:=bssolid;
  Font.Free;
end;

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

мини-пример

Там всё почти ничем не отличается от вашего варианта, кроме того, что отрисовка текста будет осуществляться на отдельный битмап предварительно залитый белым цветом с кистью bsclear, а затем просто его содержимое с помощью того-же BitBlt() на канву вашего Image1. С blend-функциями же пример внезапно станет совсем не маленьким

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

ширина текста что курсивом, что обычным - идентична, т.е. в случае курсива она определяется некорректно

На самом деле там всё непросто, и конечно-же если есть желание, то можете лезть в дебри. Чисто в теории используя GetTextExtentPoint32 и метрики можно получить точные области отрисовки текста, но всегда есть но.
Например если шрифт не является TrueType шрифтом, то в метриках текста в TTextMetric.tmOverhang указывается значение, на которое может быть увеличена ширина символа для italic или bold, однако у truetype шрифтов это значение будет нулевым, но в OutlineTextMetric.otmItalicAngle есть значение наклона шрифта, с помощью которого нехитрыми математическими манипуляциями можно вычислить величину, на которую будет увеличен символ. Однако и тут не всё просто: у некоторых truetype шрифтов это значение всегда = 0 и внезапно это tahoma, arial и подобные. А ещё есть Сleartype, который меняет сглаживание, толщину линий и тп..
Собственно чтобы полноценно рисовать текст посимвольно нужно погрузиться в дебри типографики: учитывать межсимвольные/межстрочные интервалы (они могут быть даже отрицательными), углы наклона букв, смещения, восхождение/спуск символа и т.п.

[jillitil]

по каким-то причинам некорректно рассчитывается его ширина. Особенно это проглядывается при выборе курсива - там вообще ширина получается идентичной

Это баги от художников шрифтов и форточек дяди Билли Генри Гейтса III.
Функция "TextWidth(...)" вызывает GDI 'GetTextExtentPoint...'

на выходе текст обрезается

1. Перед вызовом "TextOut" ставьте прозрачный фон Brush.Style := bsClear;
2. Заранее выбирайте хорошие шрифты, где расчёт ширины будет правильный.
3. Ставьте дополнительный пробел в конце строки для "правильного" расчёта ширины текста (да, костыль).

PROCEDURE TForm1.BitBtn2Click(Sender: TObject);
CONST     S = 'Обрезка текста при отрисовке на канве.';
VAR
    TextLength, Col, i: Integer;
    R: TRect;
BEGIN
    IF NOT FontDialog1.Execute THEN 
       Exit;
    WITH Image1.Canvas DO BEGIN
        Font.Assign(FontDialog1.Font);
        R := Rect(20, 10, 20 + TextWidth(S), 10 + TextHeight(S));

        Brush.Style := bsSolid;
        Brush.Color := clWhite;
        Pen.Color   := clBlack;
        FillRect(R);
        Rectangle(R);
        Brush.Style := bsClear;

        TextLength := Length(S);
        Col := 255 DIV TextLength;

        FOR i := 1 TO TextLength DO BEGIN
            Font.Color := RGB(i * Col, 255 - i * Col, i * Col);
            TextOut (R.Left, R.Top,     S[i] );
            Inc     (R.Left, TextWidth (S[i]) );
        END;
    END;
END;