Форум: "Основная";
Текущий архив: 2002.04.01;
Скачать: [xml.tar.bz2];

Вниз

Как написать разноцветную надпись?   Найти похожие ветки 

← →
Макс Черных   (2002-03-18 23:02) [3]

Разноцветную надпись нарисовать не так то и просто.
Вот пример, который я когда то писал на скорую руку
чтобы показать одному знакомому как это чудо делается
(точнее цель была подсветить некоторые части текста).
В проекте 1 форма на которой 1 компонент TImage, на
Canvas которого и рисуем. Так как этот пример делался
наскоро, то он естественно малость кривоват, но
принцип понять можно, осоьенно если почитать описание функции GetTextExtentExPoint

unit Unit1;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, ExtCtrls, Types;

type
TForm1 = class(TForm)
Image1: TImage;
procedure FormCreate(Sender: TObject);
private
Ftext : string;
public
procedure Test;
end;

var
Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.FormCreate(Sender: TObject);
begin
Ftext :=
"Время больше не давит на игрока! На каждый вопрос вам дается 2 минуты " +
"Введен предварительный конкурс, как это происходит и в телевизионной игре. " +
"MarkRect.Left := Swidths[16] + 2; " +
"Right := Swidths[12]+ 2; ";
Test;
end;

procedure TForm1.Test;
var R, Mr : TRect; W : Integer; NumFit : Integer;
Swidths : array[0..300] of Integer; p7 : tagSize;
S, Sd, Sm : string; HighLights : array of string;
begin
SetLength(HighLights, 3);
HighLights[0] := "";
HighLights[1] := "";
HighLights[2] := "";
R := Rect(0, 0, 500, 250);
With Image1 do begin
Canvas.Brush.Color := clWindow;
Canvas.FillRect(R);
Canvas.Font.Name := "Arial";
Canvas.Font.Size := 10;
R := Rect(10, 10, 200, 240);
S := Ftext;
W := 190;
Repeat
GetTextExtentExPoint(Canvas.Handle, Pchar(S), Length(S), W,
@NumFit, PInteger(@Swidths), p7);
While S[NumFit] <> " " do dec(NumFit);
Sd := Copy(S, 1, NumFit);
Canvas.Brush.Color := clWindow;
Canvas.Font.Color := clBlack;
DrawText(Canvas.Handle, Pchar(Sd), -1, R, DT_LEFT{ or DT_WORDBREAK});
Mr := R;
Mr.Left := Swidths[7] -2;// -1;
Sm := Copy(Sd, 7, 6);
Canvas.Brush.Color := clYellow;
Canvas.Font.Color := clRed;
TextOut(Canvas.Handle, Swidths[8] -5, R.Top, Pchar(Sm), Length(Sm));
Delete(S, 1, NumFit);
inc(R.Top, p7.cy);
until S = "";
end;
end;

end.

---

Страницы: 1 вся ветка

Форум: "Основная";
Текущий архив: 2002.04.01;
Скачать: [xml.tar.bz2];

Наверх

Память: 0.45 MB
Время: 0.005 c