Текущий архив: 2006.07.30;
Скачать: CL | DM;

Вниз

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

← →
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]

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

---

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

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

---

← →
KilkennyCat ©   (2006-07-07 04:12) [14]

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. если посчитать, то в последней строке оно становится равным нулю. Вследствие чего вместо первой буквы, вероятно, будет квадратик...

---

← →
Quattro ©   (2006-07-07 12:44) [15]

> видите жирное? это состояние 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;


---

← →
Quattro ©   (2006-07-07 12:58) [16]

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


---

← →
Quattro ©   (2006-07-07 13:10) [17]

(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;

---

← →
Quattro ©   (2006-07-07 13:17) [18]

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

---

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

Текущий архив: 2006.07.30;
Скачать: CL | DM;

Наверх

Память: 0.53 MB
Время: 0.031 c