Главная страница
    Top.Mail.Ru    Яндекс.Метрика
Форум: "Основная";
Текущий архив: 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.61 MB
Время: 0.056 c
3-92338
ghost_by
2002-10-05 03:26
2002.10.28
Счетчик!


14-92715
Aleksandr
2002-10-08 18:02
2002.10.28
Никто QuickReport под Делфи 7 не пытался присобачить?


1-92552
wer
2002-10-16 13:32
2002.10.28
Цвет caption


14-92673
Неизвестно кто
2002-10-07 15:02
2002.10.28
Delphi : Не зря ли


1-92493
Vikuksa
2002-10-17 14:26
2002.10.28
Опять Ёксель





Afrikaans Albanian Arabic Armenian Azerbaijani Basque Belarusian Bulgarian Catalan Chinese (Simplified) Chinese (Traditional) Croatian Czech Danish Dutch English Estonian Filipino Finnish French
Galician Georgian German Greek Haitian Creole Hebrew Hindi Hungarian Icelandic Indonesian Irish Italian Japanese Korean Latvian Lithuanian Macedonian Malay Maltese Norwegian
Persian Polish Portuguese Romanian Russian Serbian Slovak Slovenian Spanish Swahili Swedish Thai Turkish Ukrainian Urdu Vietnamese Welsh Yiddish Bengali Bosnian
Cebuano Esperanto Gujarati Hausa Hmong Igbo Javanese Kannada Khmer Lao Latin Maori Marathi Mongolian Nepali Punjabi Somali Tamil Telugu Yoruba
Zulu
Английский Французский Немецкий Итальянский Португальский Русский Испанский