TCanvas. Вывести текст с разноцветными буквами

← →
K-1000 © (2016-02-22 16:48) [0]

Задача: Вывести на канву текст, где каждая буква окрашена в свой цвет.

Наколдовал (Совместно с Гуглом) такой код:

function CalcTextExtent(DCHandle:integer;Text:string):TSize; var CharFSize:TABCFloat; begin Result.cx:=0; Result.cy:=0; if Text="" then exit; GetTextExtentPoint32(DCHandle,PChar(Text),Length(Text),Result); GetCharABCWidthsFloat(DCHandle,Ord(Text[Length(Text)]),Ord(Text[Length(Text)]),C harFSize); if CharFSize.abcfC<0 then Result.cx:=Result.cx+Trunc(Abs(CharFSize.abcfC)); end; function CalcTextWidth(DCHandle:integer;Text:string):integer; begin Result:= CalcTextExtent(DCHandle,Text).cx; end; function DrawMulticoloredText(DC: HDC; X, Y: LongInt; const Text: String; Colors: array of LongWord): Boolean; var i: LongInt; Letter: String; LetterWidth: LongWord; begin Result:= False; if (Length(Text) <> Length(Colors)) then Exit; SetBkMode(DC, TRANSPARENT); for i:= 1 to Length(Text) do begin Letter:= Text[i]; LetterWidth:= CalcTextWidth(DC, Letter); Inc(X, LetterWidth); SetTextColor(DC, Colors[i - 1]); if not TextOut(DC, X, Y, PChar(Letter), Length(Letter)) then Exit; end; Result:= True; end;

Использование:

DrawMulticoloredText(DC, 300, 300, "QisW", [COLOR_BLUE, COLOR_GREEN, COLOR_RED, COLOR_WHITE]);

Шрифт: "Arial Black", 20.
В итоге буквы "пляшут" или "в кучу".

Где собака зарыта?

← →
Kerk © (2016-02-22 16:50) [1]

Покажи картинку-то. Что значит пляшут или в кучу?

← →
K-1000 © (2016-02-22 16:55) [2]

> Kerk © (22.02.16 16:50) [1]
>
> Покажи картинку-то. Что значит пляшут или в кучу?

[URL=http://radikal.ru/big/60b29428fd344d98b1d55826d25b504a][IMG]http://s017.radikal.ru/i405/1602/57/f50ed0482e39.png[/IMG][/URL]

← →
K-1000 © (2016-02-22 16:56) [3]

*Вупс.

http://s017.radikal.ru/i405/1602/57/f50ed0482e39.png

← →
Dimka Maslov © (2016-02-22 17:06) [4]

А что Canvas.TextWidth, Canvas.TextOut, Canvas.Brush уже отменили?

← →
K-1000 © (2016-02-22 17:18) [5]

> Dimka Maslov © (22.02.16 17:06) [4]
>
> А что Canvas.TextWidth, Canvas.TextOut, Canvas.Brush уже
> отменили?
>

Так получилось, что проект без VCL.

← →
Kilkennycat © (2016-02-22 17:27) [6]

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

← →
Kilkennycat © (2016-02-22 17:33) [7]

а вообще задача проста. делфи под рукой нет, но будет примерно так:

в цикле для каждой буквы:
DrawText (winapi) с флагом DT_CALCRECT вычисляем ширину буквы
Прибавляем вычисленную ширину к текущей позиции
устанавливаем цвет шрифа
DrawText (winapi) без флага DT_CALCRECT рисуем букву с текущей позиции

← →
Eraser © (2016-02-23 03:27) [8]

> Kilkennycat © (22.02.16 17:27) [6]

> что не для моноширинного шрифта сделать очень сложно

как-то была задумка сделать выделение части названий элементов в TListView по аналогии с тем, как это сделано во встроенном поиске explorer"а. Задача, по сути, сходная с тем, что у топикстартера. Тоже все идеи реализации были похожи на разработку текстового редактора, отложил в долгий ящик. Так что тоже было бы интересно глянуть, наверняка есть простое решение.

← →
Pavia © (2016-02-23 12:12) [9]

Все проще при выводе текста виндоус сам смещает pen.pos.
Используйте перед циклом moveto, а в цикле DrawText.

← →
Kilkennycat © (2016-02-23 14:29) [10]

> Все проще при выводе текста виндоус сам смещает pen.pos.

при побуквенном выводе тоже только для моноширинного красиво будет. для обычного помещение части одной буквы под другую (например Wj ) не будет. будет выглядеть так: W j

← →
Pavia © (2016-02-23 15:19) [11]

http://s7.postimg.org/pi6722n9n/image.png

И что же я делаю не так раз у меня WJ и J залазит под W?
Вот моноширинный вывод как в редакотре дельфи сделать труднее.

procedure MyTextOut(str:String; Colors: array of LongWord); var i:Integer; j:Integer; DC:HDC; PenPos:TPoint; begin Form1.PaintBox1.Canvas.MoveTo(20,20); DC:=Form1.PaintBox1.Canvas.Handle; j:=0; for i:=1 to Length(Str) do begin SetTextColor(DC, Colors[J mod Length(Colors)]); Windows.GetCurrentPositionEx(DC, @PenPos); Form1.PaintBox1.Canvas.TextOut(PenPos.X, PenPos.Y, str[i]); Inc(j); end; end; procedure TForm1.Button1Click(Sender: TObject); begin Form1.PaintBox1.Font.Size:=23; MyTextOut("wjklmiÞiÆjWà", [ClBLUE, ClGREEN, ClRED, clFuchsia] ); end;

← →
Kilkennycat © (2016-02-23 15:24) [12]

> Pavia © (23.02.16 15:19) [11]

хм... да.
а у меня не залазило. мож че поменялось теперь в выводе. я под вин98 делал. и в результате как раз сделал моноширинный,чтоб убрать лишние некрасивые пропуски.

← →
Eraser © (2016-02-23 18:36) [13]

> Pavia © (23.02.16 15:19) [11]

а какая ОС и версия IDE и шрифт?

https://dl.dropboxusercontent.com/u/26403307/2016-02-23_18-32-58.png

тестировалось на windows 10, delphi 10 seattle.

← →
Eraser © (2016-02-23 18:49) [14]

> Eraser © (23.02.16 18:36) [13]

помогла установка
Form1.PaintBox1.Canvas.Brush.Style := bsClear;
перед выводом.

← →
Pavia © (2016-02-23 19:37) [15]

Да. Забыл, что PainBox берёт Form1.PaintBox1.Canvas.Brush.Color с ниже лежащего компонента (как правило формы).
А TextOut использует этот цвет в качестве фона, для закраски.

ОС Win 10.
IDE D7. Более старые надо проверять, там насколько помню ширина бралась не по каждому символу, а по "W" поэтому код и выглядел, как моноширинный.
Для старых ОС, тоже надо посмотреть.

> Pavia © (23.02.16 19:37) [15]

реализовать бы такое
https://dl.dropboxusercontent.com/u/26403307/2016-02-23_21-15-33.png

там наличие нескольких строк портит всю картину, для прорисовки нужно использовать DrawText/DrawTextEx, которые спотыкаются, при посимвольном вводе, об эту самую "мультилинейность".

Да пожалуйста.
Все баги в коде ниже объявляем фичями. ;-)

Берём RichEdit1 со стилем
RichEdit1.BorderStyle:=bsNone;

type TSegment=record Start, Length:Integer; end; var LastSelectSegment:TSegment; procedure RhichEditBackColor(RichEdit:TRichEdit; color:TColor); var Format:CHARFORMAT2A; begin SendMessage(RichEdit.Handle, EM_HIDESELECTION, 0, LongInt(True)); FillChar(Format, SizeOf(Format), 0); Format.cbSize := SizeOf(Format); SendMessage(RichEdit.Handle, EM_GETCHARFORMAT, WPARAM(False), LPARAM(@Format)); Format.dwEffects:=0; Format.dwMask:=CFM_BACKCOLOR or CFM_COLOR or CFM_FACE; Format.crTextColor:=not Format.crTextColor; Format.crBackColor:=$FFFFFF xor ColorToRGB(Color); SendMessage(RichEdit.Handle, EM_SetCHARFORMAT, WPARAM(True), LPARAM(@Format)); end; var FUpdating :Boolean; procedure TForm1.RichEdit1SelectionChange(Sender: TObject); var RichEdit:TRichEdit; SelectSegment:TSegment; begin RichEdit:=Sender as TRichEdit; if (FUpdating=False) then begin SelectSegment.Start:=RichEdit.SelStart; SelectSegment.Length:=RichEdit.SelLength; FUpdating := True; TCustomMemo(RichEdit).SelStart:=LastSelectSegment.Start; TCustomMemo(RichEdit).SelLength:=LastSelectSegment.Length; RhichEditBackColor(RichEdit, $FFFFFF xor clWhite); RichEdit.SelStart:=SelectSegment.Start; RichEdit.SelLength:=SelectSegment.Length; FUpdating := False; RhichEditBackColor(RichEdit, clYellow); LastSelectSegment:=SelectSegment; end; end;

> Pavia © (24.02.16 00:28) [17]

так к RichEdit"у вопросов то и нет, вопрос как организовать такую прорисовку самостоятельно, на картинке из [16] эксплореровский ListView, но думаю не суть важно какой компонент.

есть подозрение, что там без gdiplus не обошлось, а именно https://msdn.microsoft.com/ru-ru/library/windows/desktop/ms534720(v=vs.85).aspx

Да уж, ларчик действительно через gdi+ открывался. Вот что получилось
https://dl.dropboxusercontent.com/u/26403307/2016-02-24_4-52-50.png

Делал на основе http://landsurvival.com/delphi/METHSystem.Drawing.Graphics.MeasureCharacterRanges.html

procedure TForm1.PaintBox1Paint(Sender: TObject); var MyCanvas: TGPGraphics; BrSelect, BrFont: TGPSolidBrush; MyFont: TGPFont; CharRanges: array[0..1] of TCharacterRange; StringFormat: TGPStringFormat; sText: string; RctText: TGPRectF; MyRegions: array of TGPRegion; I: Integer; begin sText := "Long long long test text xxx yyy zzz"; MyCanvas := TGPGraphics.Create(PaintBox1.Canvas.Handle); try MyFont := TGPFont.Create("Arial", 14); BrSelect := TGPSolidBrush.Create(ColorRefToARGB(clYellow)); BrFont := TGPSolidBrush.Create(ColorRefToARGB(clBlack)); StringFormat := TGPStringFormat.Create; try CharRanges[0].First := 15; CharRanges[0].Length := 4; CharRanges[1].First := 25; CharRanges[1].Length := 3; StringFormat.SetMeasurableCharacterRanges(2, @CharRanges[0]); RctText.X := 10; RctText.Y := 10; RctText.Width := 150; RctText.Height := 200; SetLength(MyRegions, Length(CharRanges)); for I := 0 to Length(MyRegions) - 1 do begin MyRegions[I] := TGPRegion.Create; end; try MyCanvas.MeasureCharacterRanges(sText, sText.Length, MyFont, RctText, StringFormat, 2, MyRegions); for I := 0 to Length(MyRegions) - 1 do begin MyCanvas.FillRegion(BrSelect, MyRegions[I]); end; MyCanvas.DrawString(sText, sText.Length, MyFont, RctText, StringFormat, BrFont); finally for I := 0 to Length(MyRegions) - 1 do begin MyRegions[I].Free; end; end; finally StringFormat.Free; BrSelect.Free; BrFont.Free; MyFont.Free; end; finally MyCanvas.Free; end; end;

> при побуквенном выводе тоже только для моноширинного красиво
> будет. для обычного помещение части одной буквы под другую
> (например Wj ) не будет. будет выглядеть так: W j

Это называется "кернинг пар". При тупом посимвольном выводе с автосдвигом каретки он НЕ выполняется по определению. На экране может быть видна разница с правильным выводом, а может и нет. Это зависит от гарнитуры и размера шрифта.

А чтобы все было красиво как в RichEdit, правильно использовать древнюю как мамонт функцию GetCharacterPlacement. Она то как раз одним вызовом все позиции буковок правильно просчитывает.

https://imgs.xkcd.com/comics/kerning.png

TCanvas. Вывести текст с разноцветными буквами Найти похожие ветки