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

Вниз

Текстовые эффекты   Найти похожие ветки 

← →
wer   (2002-10-16 10:42) [0]

как сделать убегающий вдаль скролируемый текст (типа как в "Звездных войнах"?), можно с помощью популярных компонент.

---

← →
BOA_KAA   (2002-10-16 11:14) [1]

Вообще-то, это 3хмерная графика:-) С помощью стандартных наврядли получится. Используй OpenGL или GLScene

---

← →
KaPaT   (2002-10-16 12:23) [2]

Если без наклона то можно с помощью TRichEdit...
Используя ScrollBar

---

← →
Неконнект   (2002-10-16 13:29) [3]

> KaPaT © (16.10.02 12:23)

Без наклона можно и с помощью TImage и прочей VCL-банды:-) Можно и под углом, но вот убегающую вдаль - это ж...

---

← →
wer   (2002-10-16 13:38) [4]

а как с richedit?

---

← →
MBo   (2002-10-16 13:44) [5]

вот ж..., убегающая вдаль ;)
простой пример, только размером шрифта играем.

var
Form1: TForm1;
CurPos:Integer;
b:TBitmap;

implementation

{$R *.DFM}

procedure TForm1.Button1Click(Sender: TObject);
begin
Timer1.Enabled:=True;
CurPos:=0;
DoubleBuffered:=True;
b:=TBitmap.Create;
b.width:=PaintBox1.Width;
b.height:=PaintBox1.height;
b.Canvas.Font.Name:="Arial";
b.Canvas.Font.Color:=clLime;
b.Canvas.Brush.Style:=bsClear;
end;

procedure TForm1.Timer1Timer(Sender: TObject);
var i,y,w:integer;
begin
PatBlt(b.Canvas.Handle,0,0,b.Width,b.Height,Blackness);
y:=b.Height-CurPos;
with b.Canvas do
for i:=0 to Memo1.Lines.Count-1 do begin
Font.Size:=round((y*32)/b.Height) + 8;
w:=TextWidth(Memo1.Lines[i]);
TextOut((b.Width-w) div 2,y,Memo1.Lines[i]);
y:=y+Font.Size;
end;
PaintBox1.Canvas.Draw(0,0,b);
Inc(CurPos);
end;



---

← →
BOA_KAA   (2002-10-16 13:54) [6]

> MBo © (16.10.02 13:44)

Любопытный эффект, только явно не то:-) А так - просто класс!

---

← →
wer   (2002-10-16 15:01) [7]

Да, хорошо, только не очень гладко и без наклона :(

---

← →
MBo   (2002-10-16 15:19) [8]

>только не очень гладко и без наклона
надо делать процедуру неаффинного преобразования (прямоугольник в трапецию). В общем, несложно, гладких краев только трудновато добиться.
Другой вариант - выводить каждый символ под своим наклоном (через структуру LogFont). Это не полная иллюзия перспективы, но очень похоже, зато символы будут глаже.

---

← →
wer   (2002-10-17 08:33) [9]

to MBo
А поподробнее о втором варианте, если можно

---

← →
MBo   (2002-10-17 08:38) [10]

В FAQ должно быть - - создание шрифта или надпись под углом

---

← →
Alx2   (2002-10-17 11:44) [11]

Черновой вариант:

Работает довольно медленно и с неевклидовой геометрией.
Будет время - доработаю :)


procedure TForm1.RunText(const SL: TStrings; const Pb: TPaintBox);
var i, w, y: integer;
Bmp, WorkBmp: TBitmap;
curpos, counter, maxcounter: integer;
cf: double;

function Iterate: boolean;
procedure PrepareBmp(const Source, Dest: TBitMap);
var k, x, rx, mean, ofs: integer;
sb, db: PByteArray;
dx: double;
begin
ofs := pb.Height div 4;
Result := false;
mean := (Source.Width - 1) div 2;
dx := 0;
k := 0;
while (round(dx + ofs) < pb.Height) and (k * cf < 1) and (k + counter < Source.Height) do
begin
result := true;
sb := Source.ScanLine[k + counter];
db := Dest.ScanLine[round(dx + ofs)];
dx := dx + k * cf;
for x := 0 to Source.Width - 1 do
begin
rx := round((x - mean) * (k * cf) + mean);
if (rx >= 0) and (rx < Dest.Width) then
begin
db[2 * rx] := sb[2 * x];
db[2 * rx + 1] := sb[2 * x + 1];
end;
end;
inc(k);
end;
end;

begin
inc(counter);
PatBlt(WorkBmp.Canvas.Handle, 0, 0, bmp.Width, bmp.Height, Blackness);
PrepareBmp(Bmp, WorkBmp);
Pb.Canvas.Draw(0, 0, Workbmp);
dec(curpos);
end;


begin
counter := 0;
Bmp := TBitmap.Create;
Bmp.PixelFormat := pf16bit;
WorkBmp := TBitmap.Create;
with bmp do begin
width := Pb.Width;
Canvas.Font.Size := 18;
height := round(sl.Count * Canvas.Font.Size * 1.5) + 10 + pb.Height;
Canvas.Font.Name := "Arial";
Canvas.Font.Color := clLime;
Canvas.Brush.Style := bsClear;
y := pb.Height;
PatBlt(Canvas.Handle, 0, 0, bmp.Width, bmp.Height, Blackness);
with bmp.canvas do
for i := 0 to sl.Count - 1 do
begin
w := TextWidth(sl[i]);
TextOut((bmp.Width - w) div 2, y, sl[i]);
y := y + (Font.Size * 3) div 2; ;
end;
curpos := Pb.Height - 2;
end;
WorkBmp.width := bmp.Width;
WorkBmp.Height := pb.Height;
WorkBmp.PixelFormat := pf16bit;
cf := 1 / pb.Height;
while iterate do Application.ProcessMessages;
WorkBmp.Free;
Bmp.Free;
end;

// пример использования:
procedure TForm1.Button2Click(Sender: TObject);
begin
RunText(Memo.Lines, PaintBox);
end;


---

← →
Alx2   (2002-10-17 11:47) [12]

Да, чуть не забыл!
Ининциализация битмапов позаимствована у MBo

---

← →
Separator   (2002-10-17 12:37) [13]

Работае супер, эффек прикольный получается, тока все это еще засунуть в отдельный поток, чтоб форму не блокировал и все.

---

← →
Alx2   (2002-10-17 13:03) [14]

>Separator © (17.10.02 12:37)
Еще раз повторю: перспектива искажена и сильно :))

---

← →
Separator   (2002-10-17 13:12) [15]

Согласен, но все равно уже ближе к поставленой задаче, а вообще прикольно

---

← →
Alx2   (2002-10-17 14:02) [16]

Теперь с математикой все тип-топ!

Осталось - оптимизировать на скорость :))



procedure TForm1.RunText(const SL: TStrings; const Pb: TPaintBox);
var i, w, y: integer;
Bmp, WorkBmp: TBitmap;
curpos, counter: integer;

function Iterate: boolean;
procedure PrepareBmp(const Source, Dest: TBitMap);
var x, y, mean, tmpx, tmpy: integer;
sb, db: PByteArray;
f, x1, y1, h, h0: double;
begin
h0 := Pb.Height;
h := Pb.Height;
f := 300;
result := counter<source.Height;
mean := (Source.Width - 1) div 2;
for y := 1 to Dest.Height - 1 do
begin
db := Dest.ScanLine[Dest.Height - y];
y1 := (y * counter + y * pb.height - h0 * pb.height - y + y * f - h0 * counter + h * f + h0 - h0 * f) / (-h0 + y);
tmpy := round(y1);
if (tmpy >= 0) and (tmpy < source.Height) then
begin
sb := Source.ScanLine[tmpy];
for x := 0 to Dest.Width - 1 do
begin
x1 := -(-y + h0 - h) * mean / (-h0 + y) - x * h / (-h0 + y);
tmpx := round(x1);
if (tmpx >= 0) and (tmpx < source.Width) then
begin
db[x * 2] := sb[2 * tmpx];
db[x * 2 + 1] := sb[2 * tmpx + 1];
end;
end;
end;
end;
end;

begin
inc(counter);
PatBlt(WorkBmp.Canvas.Handle, 0, 0, bmp.Width, bmp.Height, Blackness);
PrepareBmp(Bmp, WorkBmp);
Pb.Canvas.Draw(0, 0, workbmp);
dec(curpos);
end;


begin
counter := 0;
Bmp := TBitmap.Create;
Bmp.PixelFormat := pf16bit;
WorkBmp := TBitmap.Create;
with bmp do begin
width := Pb.Width;
Canvas.Font.Size := 18;
height := round(sl.Count * Canvas.Font.Size * 1.5) + 10 + pb.Height;
Canvas.Font.Name := "Arial";
Canvas.Font.Color := clLime;
Canvas.Brush.Style := bsClear;
y := pb.Height;
PatBlt(Canvas.Handle, 0, 0, bmp.Width, bmp.Height, Blackness);
with bmp.canvas do
for i := 0 to sl.Count - 1 do
begin
w := TextWidth(sl[i]);
TextOut((bmp.Width - w) div 2, y, sl[i]);
y := y + (Font.Size * 3) div 2; ;
end;
curpos := Pb.Height - 2;
end;
WorkBmp.width := bmp.Width;
WorkBmp.Height := pb.Height;
WorkBmp.PixelFormat := pf16bit;

while iterate do
begin
Application.ProcessMessages;
end;
WorkBmp.Free;
Bmp.Free;
end;



---

← →
Alx2   (2002-10-17 14:09) [17]

Кстати, в перспективу уходит все, что нарисовано на bmp. Не только текст :))

---

← →
wer   (2002-10-17 16:46) [18]

Спасибо, работает замечательно

---

← →
Alx2   (2002-10-17 16:58) [19]

>wer © (17.10.02 16:46)
Тебе спасибо. Я хоть геометрию вспомнил :))

---

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

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

Наверх

Память: 0.49 MB
Время: 0.007 c