Координаты буквы

← →
Quattro © (2006-07-07 01:34) [0]

Доброй ночи! Подскажите, пожалуйста, а как узнать координаты буквы на, допустим, лэйбле, чтобы заменить её этой же буквой, только другого цвета?..

← →
KilkennyCat © (2006-07-07 02:09) [1]

Это очень и очень странный способ...
Но если хочется - винапишный DrawText с флагом DT_CALCRECT

← →
Quattro © (2006-07-07 02:20) [2]

хм.....есть способ проще?

← →
Германн © (2006-07-07 02:29) [3]

> м.....есть способ проще?

А для чего?
Опиши нормально задачу. А то пока что "малопонятно" - "я хочу сделать программу, в которой реализовано действо разноцветной, бегающей буквы...с помощью TextOut научился рисовать...дело за малым осталось :)."
Где, кто и как "бегает" и какое "действо" делает?

← →
KilkennyCat © (2006-07-07 03:06) [4]

Во, наваял наспех :))))

unit ccLabel;

interface

uses Windows, SysUtils, Classes, Controls, StdCtrls, Dialogs, Graphics, Messages;

type

TCCLabel = class(TLabel)
private
{ Private declarations }
protected
{ Protected declarations }
public
{ Public declarations }
FColor : TColor;
FPos : integer;
procedure paint; override;
published
{ Published declarations }
property ColorChar : TColor read FColor write FColor default clRed;
property PositionChar : integer read FPos write FPos default 1;
end;

procedure Register;

implementation

procedure TCCLabel.paint;
const
Alignments: array[TAlignment] of Word = (DT_LEFT, DT_RIGHT, DT_CENTER);
WordWraps: array[Boolean] of Word = (0, DT_WORDBREAK);
var
Rect, CalcRect, CalcRect1: TRect;
Flags: Longint;

begin
with Canvas do begin
Flags := DrawTextBiDiModeFlags(DT_EXPANDTABS or WordWraps[WordWrap] or Alignments[Alignment]);
Font := Font;
if not Transparent then begin
Brush.Color := Self.Color;
Brush.Style := bsSolid;
FillRect(ClientRect);
end;
Brush.Style := bsClear;
Rect := ClientRect;
if Layout <> tlTop then begin
CalcRect := Rect;
DrawText(Canvas.Handle, PChar(Caption), Length(Caption), CalcRect, DT_CALCRECT);
if Layout = tlBottom then OffsetRect(Rect, 0, Height - CalcRect.Bottom)
else OffsetRect(Rect, 0, (Height - CalcRect.Bottom) div 2);
end;
if not Enabled then begin
OffsetRect(Rect, 1, 1);
Canvas.Font.Color := clBtnHighlight;
DrawText(Canvas.Handle, PChar(Caption), Length(Caption), Rect, Flags);
OffsetRect(Rect, -1, -1);
Canvas.Font.Color := clBtnShadow;
DrawText(Canvas.Handle, PChar(Caption), Length(Caption), Rect, Flags);
end else begin
DrawText(Canvas.Handle, PChar(Caption), Length(Caption), Rect, Flags);
DrawText(Canvas.Handle, PChar(copy(Caption, 1, PositionChar)), PositionChar - 1, CalcRect, DT_CALCRECT);
Canvas.Font.Color := ColorChar;
OffsetRect(Rect, CalcRect.Right, 0);
DrawText(Canvas.Handle, PChar(copy(Caption, PositionChar, 1)), 1, Rect, Flags);
end;
end;
end;

procedure Register;
begin
RegisterComponents("CCLabel", [TCCLabel]);
end;

end.

← →
KilkennyCat © (2006-07-07 03:10) [5]

странно... хотел код включить, а вышел курсив....
добавлю комментарий:
property ColorChar устанавливает цвет буквы
property PositionChar выбирает позицию буквы (в коде нет проверки корректности!)

Procedure paint передрана из генофонда. добавлено лишь

DrawText(Canvas.Handle, PChar(copy(Caption, 1, PositionChar)), PositionChar - 1, CalcRect, DT_CALCRECT); Canvas.Font.Color := ColorChar; OffsetRect(Rect, CalcRect.Right, 0); DrawText(Canvas.Handle, PChar(copy(Caption, PositionChar,1)), 1, Rect, Flags); что и является вычислением буквы и заменой :))

← →
KilkennyCat © (2006-07-07 03:13) [6]

и верхнюю строчку можно упростить до
DrawText(Canvas.Handle, PChar(Caption), PositionChar - 1, CalcRect, DT_CALCRECT);

← →
KilkennyCat © (2006-07-07 03:25) [7]

гм... и еще надо добавить возвращенияе цвета фонта...

← →
Quattro © (2006-07-07 03:31) [8]

> А для чего?

Допустим есть надпись "ЛЕНИН ЖИВ!"...хочу чтобы одна буква была другого цвета (допустим красного) и чтобы этот цвет в каждый момент времени подсвечивал следующую по порядку в слове букву...к примеру, в момент 1 буква Л красная..в момент 2 уже буква Е красная, а буква Л приобрела родной черный цвет..и так далее :)..вот что то наколупал, прошу сделать резонные замечания :)
procedure TForm1.FormCreate(Sender: TObject); begin x:=0;\\координата буквы по Х z:=0;\\номер буквы в слове y:=10;\\координата буквы по Y e:=0;\\переменная для запоминания координаты предыдущей буквы end; procedure TForm1.Edit1KeyDown(Sender: TObject; var Key: Word; Shift: TShiftState); begin if Key = VK_RETURN then begin for z:=1 to Length(Edit1.Text) do begin Label1.Canvas.TextOut(x,y,Edit1.Text[z]); // вручную рисуем надпись с учетом пробела между буквами x:=x+Label1.Canvas.TextWidth(Edit1.Text[z])+10;\\10 - это мой, самопальный, межбуквенный пробел end; x:=0; z:=0; end; end; procedure TForm1.Button2Click(Sender: TObject); begin Timer1.Enabled:= not Timer1.Enabled;\\Запускаем таймер end; procedure TForm1.Timer1Timer(Sender: TObject); begin z:=z + 1; if z > Length(Edit1.Text) then begin Label1.Canvas.Font.Color:=clBlack; Label1.Canvas.TextOut(e,y,Edit1.Text[z-1]);\\Делаем черной последнюю букву z:= 1; x:=0; e:=0; end; if z = 1 then begin Label1.Canvas.Font.Color:=clRed; Label1.Canvas.TextOut(x,y,Edit1.Text[z]); e:=x; //Запоминаем координату по Х предыдущей буквы x:=x+Label1.Canvas.TextWidth(Edit1.Text[z])+10; Exit; end; Label1.Canvas.Font.Color:=clBlack; Label1.Canvas.TextOut(e,y,Edit1.Text[z-1]); Label1.Canvas.Font.Color:=clRed; Label1.Canvas.TextOut(x,y,Edit1.Text[z]); e:=x; x:=x+Label1.Canvas.TextWidth(Edit1.Text[z])+10; // 10 - это пробел между буквами end;

← →
Quattro © (2006-07-07 03:34) [9]

> KilkennyCat © (07.07.06 03:06) [4]

что то сложновато, не находите?:)

← →
KilkennyCat © (2006-07-07 03:38) [10]

> [8] Quattro © (07.07.06 03:31)

есть у меня сомнения, что TextWidth врет, скажем, на курсиве...

вот так должен выглядеть последний кусок CCLabel:

DrawText(Canvas.Handle, PChar(Caption), Length(Caption), Rect, Flags); DrawText(Canvas.Handle, PChar(Caption), PositionChar - 1, CalcRect, DT_CALCRECT); oldcolor := Canvas.Font.Color; Canvas.Font.Color := ColorChar; OffsetRect(Rect, CalcRect.Right, 0); DrawText(Canvas.Handle, PChar(copy(Caption, PositionChar, 1)), 1, Rect, Flags); Canvas.Font.Color := oldColor;

http://www.a-cons.com/111.zip - это я наваял , на основе CCLabel (150 кил весит примерно)

исходник:
unit Unit1; interface uses Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, ccLabel, ExtCtrls; type TForm1 = class(TForm) CCLabel1: TCCLabel; Timer1: TTimer; procedure Timer1Timer(Sender: TObject); procedure FormCreate(Sender: TObject); private { Private declarations } public { Public declarations } end; var Form1: TForm1; z : integer; implementation {$R *.dfm} procedure TForm1.Timer1Timer(Sender: TObject); begin if CCLabel1.PositionChar + 1 > length(CCLabel1.Caption) then z := -1 else if CCLabel1.PositionChar - 1 = 0 then z := 1; CCLabel1.PositionChar := CCLabel1.PositionChar + z; cclabel1.Paint; end; procedure TForm1.FormCreate(Sender: TObject); begin CCLabel1.ColorChar := clRed; CCLabel1.PositionChar := 1; z := 1; timer1.Enabled := true; end; end.

← →
KilkennyCat © (2006-07-07 03:43) [11]

> [9] Quattro © (07.07.06 03:34)

Угу. но я исходил именно: использование TLabel, определение координат буквы, замена ее другим цветом. То есть, исходил из ТЗ сабжа.

Если исходить из конкретно Вашей задачи, "бегущей" буквы, то я бы вообще не стал применять TLabel...

← →
KilkennyCat © (2006-07-07 03:45) [12]

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

что касается Вашего кода:
Он не работает....
вероятно, не весь опубликован?
Ибо, у меня не произошло инициализация Label1 - надпись не изменилась...

if z = 1 then begin Label1.Canvas.Font.Color:=clRed; Label1.Canvas.TextOut(x,y,Edit1.Text[z]); e:=x; x:=x+Label1.Canvas.TextWidth(Edit1.Text[z])+10; Exit; end; Label1.Canvas.Font.Color:=clBlack; Label1.Canvas.TextOut(e,y,Edit1.Text[z-1]);

видите жирное? это состояние z. если посчитать, то в последней строке оно становится равным нулю. Вследствие чего вместо первой буквы, вероятно, будет квадратик...

> видите жирное? это состояние z. если посчитать, то в последней
> строке оно становится равным нулю. Вследствие чего вместо
> первой буквы, вероятно, будет квадратик...

если z=1 то до последней строки дело не дойдет...произойдет выход из процедуры
if z = 1 then begin Label1.Canvas.Font.Color:=clRed; Label1.Canvas.TextOut(x,y,Edit1.Text[z]); e:=x; x:=x+Label1.Canvas.TextWidth(Edit1.Text[z])+10; Exit; end;

> что касается Вашего кода:
> Он не работает....
> вероятно, не весь опубликован?
> Ибо, у меня не произошло инициализация Label1 - надпись
> не изменилась..

Вот весь код..у меня работает.....
unit Unit1; interface uses Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, ExtCtrls; type TForm1 = class(TForm) Label1: TLabel; Button1: TButton; Timer1: TTimer; Edit1: TEdit; procedure FormCreate(Sender: TObject); procedure Edit1KeyDown(Sender: TObject; var Key: Word; Shift: TShiftState); procedure Button1Click(Sender: TObject); procedure Timer1Timer(Sender: TObject); private { Private declarations } public { Public declarations } end; var Form1: TForm1; x,y,z,e,a:Integer; TimerFlag:Boolean; implementation {$R *.dfm} procedure TForm1.FormCreate(Sender: TObject); begin x:=0; //Координата Х z:=0; //Номер буквы в слове y:=10; //Координата Y e:=0; // Для запоминания коорд. Х предыдущей буквы a:=0; // Для запоминания коорд. Y предыдущей буквы TimerFlag:=False; end; procedure TForm1.Edit1KeyDown(Sender: TObject; var Key: Word; Shift: TShiftState); begin if Key = VK_RETURN then begin x:=0; y:=0; Label1.Canvas.Brush.Color:=clBtnFace; Label1.Canvas.FillRect(Canvas.ClipRect); if TimerFlag then begin Timer1.Enabled:=False; x:=0; y:=0; e:=0; z:=0; end; for z:=1 to Length(Edit1.Text) do begin Label1.Canvas.Font.Color:=clBlack; Label1.Canvas.TextOut(x,y,Edit1.Text[z]); // вручную рисуем надпись, с учётом пробела м/у буквами x:=x+Label1.Canvas.TextWidth(Edit1.Text[z])+15;//15-это мой пробел м/у буквами if x+24 > Label1.Width then begin x:=0; y:=y + 40; end; end; x:=0; z:=0; y:=0; end; end; procedure TForm1.Button1Click(Sender: TObject); begin Timer1.Enabled:= not Timer1.Enabled; TimerFlag:= true; end; procedure TForm1.Timer1Timer(Sender: TObject); begin z:=z + 1; if z > Length(Edit1.Text) then begin Label1.Canvas.Font.Color:=clBlack; Label1.Canvas.TextOut(e,a,Edit1.Text[z-1]); //меняем цвет последней буквы на родной z:= 1; x:=0; e:=0; a:=0; y:=0; end; if z = 1 then begin Label1.Canvas.Font.Color:=clRed; Label1.Canvas.TextOut(x+5,y-3,Edit1.Text[z]); e:=x; //Запоминаем координату Х предыд. буквы a:=y; //Запоминаем координату Y предыд. буквы x:=x+Label1.Canvas.TextWidth(Edit1.Text[z])+10; Exit; end; Label1.Canvas.Font.Color:=clBlack; Label1.Canvas.TextOut(e,a,Edit1.Text[z-1]); Label1.Canvas.Font.Color:=clRed; Label1.Canvas.TextOut(x+3,y-3,Edit1.Text[z]); e:=x; //Запоминаем координату Х предыд. буквы a:=y; //Запоминаем координату Y предыд. буквы x:=x+Label1.Canvas.TextWidth(Edit1.Text[z])+15; // 15 - мой пробел м/у буквами if x+24 > Label1.Width then begin x:=0; y:=y + 40; end; end; end.

(x + 5) и (y - 3) это служит для эффекта подпрыгивания буквы...на 24 - шрифте работало :)
Label1.Canvas.TextOut(x+5,y-3,Edit1.Text[z]);
Здесь + 15 вместо +10 - опечатка вышла :)
x:=x+Label1.Canvas.TextWidth(Edit1.Text[z])+10;

у меня в лэйбле был 24 шрифт, жирный курсив

Координаты буквы Найти похожие ветки