PHP DM Gate v0.9 » Титры

Крош (08.02.12 11:08) [0]

Добрый день, Уважаемые знатоки. Подскажите пожалуйста, как реализовать эффект бесконечных титров (вертикального скроллинга текста). Прокрутка мемо (всем устраивает, если бы не дергались строки, т.е. не плавно прокручиваются), перемещение метки тоже не вариант (дергается). Подскажите как такое сотворить. Пример будет только в радость, который приму с великой благодарностью.

<Цитата>
Крош (08.02.12 11:12) [1]

P.S.
Текст не фиксированный, а подгружается из текстового файла.

<Цитата>
Vladimyr © (08.02.12 14:19) [2]

можно рисовать текст на канве...
конечно, придётся чуток разобраться, как именно, но это несложно
зато потом можно делать это абсолютно так, как хочется!

<Цитата>
Крош (10.02.12 00:25) [3]

Плиз. Подскажите.
...
Timer1: TKOLTimer;
PB2: TKOLPaintBox;
...
x,y,i:Integer;
s:PStrList;
...
procedure TForm1.KOLFormFormCreate(Sender: PObj);
begin
x:=PB2.Width div 7;
y:=PB2.Height;
i:=1;
PB2.Font.FontName:='Tahoma';
s:=NewStrList;
s.LoadFromFile('readme.txt');
end;

procedure TForm1.Timer1Timer(Sender: PObj);
begin
y:=y-1;
if y=-10*s.Count then y:=PB2.height+10;
PB2.Canvas.Font.Color:=$000576DC;
for i:=1 to s.Count do begin
PB2.Canvas.TextOut(x,y+10*i, s.Items[i]);
end;

Все рисуется, крутится, однако сильно сомневаюсь в правильности сего решения.
1. немного мерцает (но с прокруткой мемо не сравнить),
2. Как правильно добиться вывода текста по центру.

<Цитата>
Крош (10.02.12 01:28) [4]

Обнаружил архив форума, если скачать, то как его локально можно смотреть?

<Цитата>
G-Host © (10.02.12 02:07) [5]

1. Таймер должен только изменять переменную y и вызывать перерисовку необходимой области. Сама работа с канвой должна проходить в методе OnPaint.
2. Получай размер строки при помощи TCanvas.TextExtent

<Цитата>
Vladimyr © (10.02.12 09:17) [6]

я делал так:
1. создавал два битмапа
2. рисовал на одном текст
3. выводил его на канву
4. рисовал текст на другом
5. менял их местами
ничего не мерцает, работает мухой даже на очень медленных
процах (КПК)

чтобы отцентрировать текст, надо исп. ф-цию рисования,
которая не рисует, но позволяет узнать получившийся размер
(не помню, как она называется), затем рассчитать новое
положение текста, уже зная размер, который он займёт...
и потом рисовать "по-настоящему"

<Цитата>
Vladimyr © (10.02.12 09:17) [7]

собссно, TextExtent :))

<Цитата>
Крош (10.02.12 11:36) [8]

Спасибо Вам всем. Все переделал.
Vladimyr, а можно увидеть Ваше решение? Для меня пока все это немного туманно, поэтому буду рад посмотреть как Вы это реализовали.

<Цитата>
Крош (11.02.12 00:55) [9]

Под семеркой с аэро, PaintBox почему то становится прозрачным. Под XP все нормально, под 7 с упрощенной темой тоже. Что не так?

<Цитата>
Крош (11.02.12 11:32) [10]

При создании формы:
Bmp2 := NewBitmap( PB2.Width, PB2.Height );
Bmp2.BkColor:=clBlack;
В событие отрисовки PaintBox, перед рисованием на канве добавил
Bmp2.Draw(PB2.Canvas.Handle,0,0);
Теперь PaintBox не прозрачный, но сильно мерцает :(

<Цитата>
RusSun © (11.02.12 20:32) [11]

Всем привет)
to Vladimir можно посмотреть на Ваше решение )
у меня тоже простенький вариант получился а вот

> 5. менял их местаминичего не мерцает, работает мухой даже
> на очень медленных

не очень получается.

<Цитата>
Крош (14.02.12 19:25) [12]

Вывожу текст:
DrawText(PaintBox.Canvas.Handle,pchar(s),length(s),r,DT_CENTER);
Никак не могу изменить шрифт и цвет(рисует черным цветом с белым фоном). Ясен день, что как то просто, но не получается....

<Цитата>
RusSun © (14.02.12 19:57) [13]

PaintBox.Font.FontHeight := 30;

PaintBox.Canvas.Font.Color := TColor(clBlue);

<Цитата>
Крош (14.02.12 20:03) [14]

Сорри, как и думал, малость тупанул.

<Цитата>
Крош (14.02.12 20:08) [15]

to RusSun
так почемуто не работает...
а вот так пашет:
SetTextColor(PaintBox.Canvas.Handle,clWhite);

<Цитата>
RusSun © (14.02.12 20:12) [16]

procedure TimerTimer(Dummy : Pointer;Sender:PControl);
begin
y:=y-2;
if y=-10*s.Count then y:=PB2.height+20;
//PB2.Canvas.Font.Color:=$008000 ;//$000576DC
PB2.Font.FontHeight := 30;

PB2.Canvas.Font.Color := TColor(clBlue);
//PB2.canvas.font
for i:=1 to s.Count do begin
PB2.Canvas.TextOut(x,y+20*i, s.Items[i]);

end;

end;

<Цитата>
RusSun © (14.02.12 20:17) [17]

http://s1.ipicture.ru/uploads/20120214/tC7LtTfh.png

<Цитата>
Крош (14.02.12 20:44) [18]

Это да, в этом случае без проблем, но если использовать не TextOut, а DrawText (красивее выводится текст):
...
pos: integer;
R: TRect;
...
pos:=PB2.Top;
...
procedure TForm1.Timer1Timer(Sender: PObj);
begin
r.left:=1;
r.top:=pos;
r.Right:=PainBox.Width;
r.Bottom:=PainBox.Height;

dec(pos);

PB2.Canvas.Brush.Color:=clBlack; // 1
PB2.Canvas.Brush.BrushStyle:= bsClear; //2
DrawText(PB2.Canvas.Handle,pchar(s),length(s),r,DT_CENTER);
if pos<-PB2.Height then pos:=220;
end;

Если без строк 1 и 2 то выводит красиво, но не тем шрифтом и цветом и затирает фон. С 1 и 2 все размазывается.

<Цитата>
Крош (14.02.12 21:12) [19]

Млин, напутал.
Не:
PB2.Canvas.Brush.Color:=clBlack; // 1
PB2.Canvas.Brush.BrushStyle:= bsClear; //2
а
SetTextColor(PB2.Canvas.Handle,clWhite); //1
SetBkMode(PB2.Canvas.Handle,TRANSPARENT); //2

<Цитата>
Vladimir Kladov © (14.02.12 21:38) [20]

Список демок смотрели?

<Цитата>
Крош (14.02.12 22:01) [21]

Спасибо, Smooth scrolling on paint box using thread.
Буду изучать.

<Цитата>
RusSun © (16.02.12 20:32) [22]

program Project1;

uses
windows,messages,
kol;
type TOnEvent = procedure( Sender: PObj )of object;
TOnThreadExecute = function(Sender:PThread): Integer of object;
TObjectMethod = procedure of object;

{$R *.res}
var
form,PBox,Pan,
EB1,B1,B2,L1,
Use_Scroll,Half_pixel:PControl;

Thread1:PThread;

OffsetX: Integer;
//LastTik: DWORD;
Bmp, Bmp2: PBitmap;

TextToScroll: String = 'Sample smooth scrolling text';
Period: DWORD = 16; // better values = N * (1000 / VSync_in_Hertz)
useScroll: Boolean = TRUE;
halfPixel: Boolean = TRUE;
step: Integer;

//область для процедур
procedure PBoxPaint(dummy:pointer;Sender: PControl; DC: HDC);
var R: TRect;
Big, B: PBitmap;
h: Integer;
begin
if (Bmp <> nil)
and (Bmp.Width <> PBox.Width)
and (Bmp.Height <> PBox.Height) then
Free_And_Nil( Bmp );
if Bmp = nil then
begin
Bmp := NewBitmap( PBox.Width, PBox.Height );
Bmp.Canvas.Brush.Color := clWindow;
Bmp.Canvas.Font.Assign( PBox.Font );
Bmp.Canvas.Font.FontQuality := fqAntialiased;
h := Bmp.Canvas.TextHeight(TextToScroll);
Bmp.Canvas.TextRect( Bmp.BoundsRect, 0, (Bmp.Height - h) div 2,
TextToScroll );
//Bmp.SaveToFile( GetStartDir + 'bmp.bmp' );

Big := NewDibBitmap( Bmp.Width*2, Bmp.Height, pf32bit );
Big.Canvas.Brush.Color := clWindow;
Big.Canvas.FillRect( Big.BoundsRect );
SetStretchBltMode( Big.Canvas.Handle, halftone );
Bmp.StretchDraw( Big.Canvas.Handle, MakeRect( 1, 0, Big.Width+1, Big.Height ) );

Bmp2 := NewDibBitmap( Bmp.Width, Bmp.Height, pf32bit );
SetStretchBltMode( Bmp2.Canvas.Handle, halftone );
Big.StretchDraw( Bmp2.Canvas.Handle, Bmp2.BoundsRect );
//Bmp2.SaveToFile( GetStartDir + 'bmp2.bmp' );
Big.Free;
end;

if step and 1 = 1 then
B := Bmp
else
B := Bmp2;
R := PBox.ClientRect;
// OffsetRect( R, -OffsetX,0 );
OffsetRect( R, 0, -OffsetX);
B.Draw( Sender.Canvas.Handle, R.Left, R.Top );
// OffsetRect( R, PBox.Width, 0 );
OffsetRect( R, 0, PBox.Height );
B.Draw( Sender.Canvas.Handle, R.Left, R.Top );

if Thread1.Suspended then
Thread1.Resume;
end;
procedure FormDestroy(dummy:pointer;Sender: PObj);
begin
Free_And_Nil( Bmp );
Free_And_Nil( Bmp2 );
end;

procedure EB1Change(dummy:pointer;Sender: PObj);
var n: Integer;
begin
n := Str2Int( EB1.Text );
if n > 0 then
Period := n;
end;

procedure B1Click(dummy:pointer;Sender: PObj;var mouse:TMouseEventData);
var n: Integer;
begin
n := Str2Int( EB1.Text ) - 1;
if n > 0 then
EB1.Text := Int2Str( n );
end;

procedure B2Click(dummy:pointer;Sender: PObj;var mouse:TMouseEventData);
var n: Integer;
begin
n := Str2Int( EB1.Text ) + 1;
if n > 0 then
EB1.Text := Int2Str( n );
end;

function PBoxMessage(dummy:pointer;var Msg: tagMSG;
var Rslt: Integer): Boolean;
begin
Result := FALSE;
if Msg.message = WM_ERASEBKGND then
begin
Result := TRUE;
Rslt := 1;
end;
end;

{procedure TForm1.KOLForm1FormCreate(Sender: PObj);
begin
//SetThreadPriority( GetCurrentThread, THREAD_PRIORITY_ABOVE_NORMAL );
end; }

procedure Use_ScrollClick(dummy:pointer;Sender: PObj);
begin
useScroll := Use_Scroll.Checked;
end;

function Thread1Execute(dummy:pointer;Sender: PThread): Integer;
begin
step := 0;
while not AppletTerminated do
begin
inc( step );
if (step and 1 = 0) or not halfPixel then
begin
inc( OffsetX );
if OffsetX >= PBox.Height then // PBox.Width
OffsetX := 0;
end;
if useScroll
and (not halfPixel
or halfPixel and (step and 1 = 0)) then
begin
ScrollWindow( PBox.Handle, 0,-1 , nil, nil );
end
else
begin
PBox.Invalidate;
end;
PBox.Update;
Sleep( Period );

end;
Result := 0;
end;

procedure PBoxResize(dummy:pointer;Sender: PObj);
begin
PBox.Invalidate;
PBox.Update;
end;

procedure Half_pixelClick(dummy:pointer;Sender: PObj);
begin
halfPixel := Half_pixel.Checked;
end;

Begin
form:=NewForm(Applet,'Form1').SetClientSize( 431, 71 ).setposition(330,300);
form.Font.FontHeight := 16;
form.Font.FontName := 'Arial';
PBox := NewPaintBox( Form ).SetAlign ( caClient );
{$IFDEF UNICODE_CTRLS}
PBox.SetUnicode(TRUE);
{$ENDIF UNICODE_CTRLS} //for win7
PBox.Font.FontStyle := [ fsBold ];
Pan := NewPanel(Form, esRaised ).SetAlign ( caBottom ).SetSize( 0, 33 );

{$IFDEF UNICODE_CTRLS}
Panel1.SetUnicode(TRUE);
{$ENDIF UNICODE_CTRLS}

L1 := NewLabel( Pan, 'Period: ' ).SetAlign ( caLeft ).AutoSize( TRUE );

{$IFDEF UNICODE_CTRLS}
L1.SetUnicode(TRUE);
{$ENDIF UNICODE_CTRLS}

L1.VerticalAlign := KOL.vaCenter;

EB1 := NewEditBox( Pan, [ ] ).SetAlign ( caLeft ).SetSize( 108, 0 );
{$IFNDEF UNICODE_CTRLS}EB1.SetUnicode( TRUE );{$ENDIF}
EB1.Text := '16';
EB1.Color := TColor(clWindow); // Цвет окна
B1 := NewButton( Pan, '<' ).SetAlign ( caLeft ).SetSize( 30, 0 );
{$IFDEF UNICODE_CTRLS}
B1.SetUnicode(TRUE);
{$ENDIF UNICODE_CTRLS}

B2 := NewButton(Pan, '>' ).SetAlign ( caLeft ).SetSize( 30, 0 );
{$IFDEF UNICODE_CTRLS}
B2.SetUnicode(TRUE);
{$ENDIF UNICODE_CTRLS}

Use_Scroll := NewCheckBox( Pan, 'Use Scroll' ).SetAlign ( caLeft ).AutoSize( TRUE );
{$IFDEF UNICODE_CTRLS}
Use_Scroll.SetUnicode(TRUE);
{$ENDIF UNICODE_CTRLS}
Use_Scroll.Checked := TRUE;
// Result.Half_pixel.TabOrder = 4
Half_pixel := NewCheckBox( Pan, '1/2 pixel' ).SetAlign ( caLeft );

{$IFDEF UNICODE_CTRLS}
Half_pixel.SetUnicode(TRUE);
{$ENDIF UNICODE_CTRLS}
Half_pixel.Checked := TRUE;

//.centeronparent.Tabulate;
//область для работы
form.OnDestroy:=TOnEvent(MakeMethod(nil,@FormDestroy));
Thread1:= NewThreadEx(TOnThreadExecute(MakeMethod(nil,@Thread1Execute)));
Thread1.Resume;

EB1.OnChange :=TOnEvent(MakeMethod(nil,@EB1Change));
B1.OnClick :=TOnEvent(MakeMethod(nil,@B1Click));
B2.OnClick :=TOnEvent(MakeMethod(nil,@B2Click));
PBox.OnMessage :=TOnMessage(MakeMethod(nil,@PBoxMessage));
PBox.OnPaint :=TOnPaint(MakeMethod(nil,@PBoxPaint));
PBox.OnResize :=TOnEvent(MakeMethod(nil,@PBoxResize));
Half_pixel.OnClick :=TOnEvent(MakeMethod(nil,@Half_pixelClick));
Use_Scroll.OnClick :=TOnEvent(MakeMethod(nil,@Use_ScrollClick));
Run(form);
end.

<Цитата>
RusSun © (16.02.12 20:59) [23]

НЕ
Panel1.SetUnicode(TRUE);

-опечатка, а
Pan.SetUnicode(TRUE);

<Цитата>
rdnks (18.02.12 18:50) [24]

http://narod.ru/disk/41126662001/
ddd.7z.html

Пример здоровый из-за zlib и grush, так как просто из проекта выдернул.

<Цитата>
rdnks (18.02.12 18:50) [24]

http://narod.ru/disk/41126662001/
ddd.7z.html

Пример здоровый из-за zlib и grush, так как просто из проекта выдернул.

<Цитата>
rdnks (18.02.12 18:50) [24]

http://narod.ru/disk/41126662001/
ddd.7z.html

Пример здоровый из-за zlib и grush, так как просто из проекта выдернул.

<Цитата>
rednakse © (22.09.12 13:36) [27]

2 RusSun стоит убедится что модуль uFMOD совместим с редакцией Delphi, указатели в параметрах, которые передаются в функции not nil =)

Вот страница на sourceforge. Была полная документация, вроде как даже русская.
http://ufmod.sourceforge.net/

<Цитата>