घर
Top.Mail.Ru Yandeks.Metrika
मंच: "अन्य";
वर्तमान संग्रह: 2017.01.15;
डाउनलोड करें: [xml.tar.bz2];

नीचे

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]


> केरक © (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]


> डिमका मैस्लोव © (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]


> किलकेनीकट © (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&#222;i&#198;jW&#224;",  [ClBLUE, ClGREEN, ClRED, clFuchsia] );
end;



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


> पाविया © (23.02.16 15: 19) [11]

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



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


> पाविया © (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]


> इरेज़र © (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" поэтому код и выглядел, как моноширинный.
Для старых ОС, тоже надо посмотреть.



Eraser ©   (2016-02-23 21:20) [16]


> पाविया © (23.02.16 19: 37) [15]

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

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



Pavia ©   (2016-02-24 00:28) [17]

हाँ, कृपया।
Все баги в коде ниже объявляем фичями. ;-)

Берём 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;



Eraser ©   (2016-02-24 03:18) [18]


> पाविया © (24.02.16 00: 28) [17]

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



Eraser ©   (2016-02-24 03:23) [19]

संदेह है कि gdiplus वहाँ नहीं था, अर्थात् https://msdn.microsoft.com/ru-ru/library/windows/desktop/ms534720(v=vs.85).aspx



Eraser ©   (2016-02-24 04:54) [20]

Да уж, ларчик действительно через 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;



Макс Черных ©   (2016-02-25 02:22) [21]


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


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

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



Kerk ©   (2016-02-25 11:38) [22]

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



पन्ने: 1 पूरी शाखा

मंच: "अन्य";
वर्तमान संग्रह: 2017.01.15;
डाउनलोड करें: [xml.tar.bz2];

ऊपर









मेमोरी: 0.66 एमबी
समय: 0.08 c
15-1454623843
KilkennyCat
2016-02-05 01:10
2017.01.15
नेटवर्क के बारे में समस्या।


2-1420390534
भूत डेल वोंट
2015-01-04 19:55
2017.01.15
OCX


15-1447436787
तिथि
2015-11-13 20:46
2017.01.15
मुझे मेरे एसक्यूएल द्वारा बताओ


2-1430280290
kudatsky
2015-04-29 07:04
2017.01.15
X6 में AQTime प्रोफाइलर कहां है?


3-1308823507
टिमोफी यू
2011-06-23 14:05
2017.01.15
अदो और पहुंच





अफ्रीकी अल्बानियन अरबी भाषा अर्मेनियाई आज़रबाइजानी बस्क बेलारूसी बल्गेरियाई कैटलन सरलीकृत चीनी) चीनी पारंपरिक) क्रोएशियाई चेक डेनिश डच अंग्रेज़ी एस्तोनियावासी फिलिपिनो फिनिश फ्रेंच
गैलिशियन् जॉर्जियाई जर्मन यूनानी हाईटियन यहूदी हिंदी हंगरी आइसलैंड का इन्डोनेशियाई आयरिश इतालवी जापानी कोरियाई लात्वीयावासी लिथुआनियाई मेसीडोनियन मलायी मोलतिज़ नार्वेजियन
फ़ारसी पोलिश पुर्तगाली रोमानियाई रूसी सर्बियाई स्लोवाक स्लोवेनियाई स्पेनिश स्वाहिली स्वीडिश थाई तुर्की यूक्रेनी उर्दू वियतनामी वेल्श यहूदी बंगाली बोस्नियाई
सिबुआनो एस्पेरांतो गुजराती हौसा हमोंग ईग्बो जावानीस कन्नड़ खमेर लाओ लैटिन माओरी मराठी मंगोलियन नेपाली पंजाबी सोमाली तामिल तेलुगु योरूबा
ज़ुलु
Английский Французский Немецкий Итальянский Португальский Русский Испанский