滚动式的字幕是如何实现的？

Question

请教。

Answer 1

unit cwScrollText;interfaceuses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  ExtCtrls;//DsgnIntf;type
  Tdirection=(BottomToTop,TopToBottom);
  Tposition=(pLeft,pCenter,pRight);
  TcwScrollText = class(TGraphicControl)
  private
    timer:Ttimer;
//    fAbout:string;
    nowx,nowy:integer;
    FFont:TFont;
    Fbgcolor:Tcolor;
    Fspeed:Integer;
    Flines:Tstrings;
    Fdirection:Tdirection;
    Fpos:Tposition;
    Fpicture:Tbitmap;
    FVisible:boolean;    procedure ScrollText(sender:Tobject);
    procedure SetLines(Value:Tstrings);
    procedure SetFont(Value:Tfont);
    procedure Setbgcolor(Value:Tcolor);
    procedure SetPicture(Value:Tbitmap);
    procedure SetSpeed(Value:integer);
    procedure SetPos(Value:Tposition);
    procedure SetVisible(Value:boolean);
  protected
    { Protected declarations }
    destructor Destroy; override;
  public
    { Public declarations }    constructor Create(aOwner : TComponent); override;
    procedure Paint;override;
  published
    { Published declarations }
    property Font:Tfont read Ffont write Setfont;
    property Speed:Integer read Fspeed write SetSpeed default 3;
    property Bgcolor:Tcolor read Fbgcolor write Setbgcolor default clblack;
    property Lines:Tstrings read Flines write Setlines ;
    property Direction:Tdirection read Fdirection write Fdirection default BottomTotop;
    property Position:Tposition read Fpos write Setpos default pCenter;
    property Picture :Tbitmap read FPicture write SetPicture;
    property Visible :boolean read FVisible write SetVisible default true;
    property Align;
    property Cursor;
    property ShowHint;    property OnClick  ;  end;
procedure Register;implementation{$R scrolltext.res}
procedure Register;
begin
  RegisterComponents('Scroll', [TcwScrollText]);
end;procedure TcwScrollText.paint;
begin
     canvas.FillRect(canvas.ClipRect);
end;
procedure TcwScrollText.SetFont(Value:Tfont);
begin
    FFont.Assign(Value);
    Canvas.Font.Assign(Value);
    repaint;
end;procedure TcwScrollText.SetVisible(Value:Boolean);
begin
  if Fvisible<> Value then begin
     FVisible:=Value;
  end;
  if not (csDesigning in ComponentState) then
     Timer.Enabled:=Value;
  if not Value then  Hide
    else show;
end;
procedure TcwScrollText.SetLines(Value:Tstrings);
begin
    Flines.Assign(Value);
    repaint;
    nowy:=1000000;
end;procedure TcwScrollText.SetPos(Value:Tposition);
begin
    Fpos:=Value;
    repaint;
end;
procedure TcwScrollText.SetPicture(Value:Tbitmap);
begin
    Fpicture.Assign(Value);
    repaint;
end;procedure TcwScrollText.Setbgcolor(Value:Tcolor);
begin
    Fbgcolor:=Value;
    canvas.Brush.Color:=Value;
    repaint;
end;procedure TcwScrollText.SetSpeed(Value:integer);
begin
    if Value<0 then Fspeed:=0
    else Fspeed:=Value;
    repaint;
end;procedure tcwScrolltext.ScrollText(sender:Tobject);
var i,txtheight,temp,picheight,f:integer;
begin
    f:=-abs(ffont.height)-1;
    with self.Canvas do begin
          for i:=0 to flines.Count-1 do
          try
              temp:=nowy-i*Ffont.height;
              if ( temp>self.height -f) or (temp< f) then
               continue;
              case Fpos of
              pleft  :nowx:=2;
              pCenter:nowx:=(width-TextWidth(Flines[i]))div 2;
              pRight :nowx:=width-Textwidth(Flines[i])-2;
              end;
              TextRect(rect(0,temp,width,temp-f),nowx,temp,Flines[i]);
          except
              break;
          end;
    if Fpicture.Empty then
       picheight:=0
    else begin
         if Fpos = pCenter then
            nowx:=(width-Fpicture.Width)div 2
         else if Fpos = pRight then
            nowx:=(width-Fpicture.width);
         picheight:=Fpicture.height;
    end;
    txtheight:=(Flines.count)*(-F);
    temp:=temp-F;
    if Direction=BottomToTop then  begin
       FillRect(rect(0,temp,width,temp+Speed));
       if not Fpicture.Empty then begin
          Draw(nowx,temp,Fpicture);
          FillRect(rect(0,temp+picheight,width,temp+picheight+fspeed));
       end;
       if (nowy<=-txtheight-picheight) or (nowy>height) then
          nowy:=height
       else
          nowy:=nowy-speed;
    end
    else begin
       if not Fpicture.Empty then Draw(nowx,temp,Fpicture);
       FillRect(rect(0,nowy-speed,width,nowy));
       if (nowy>height) or (nowy< -txtheight-picheight) then
           nowy:=-txtheight-picheight
       else nowy:=nowy+speed;
    end;
    end;
end;constructor Tcwscrolltext.create(aOwner : TComponent);
begin
 inherited create(aOwner);
 Fpicture:=Tbitmap.Create;
 FFont:=Tfont.Create;
 Flines:=Tstringlist.Create;
 Flines.Add('TcwScrollText');
 Flines.Add('Writen by Chenwei');
 timer:=Ttimer.Create(self);
 timer.Enabled:=false;
 timer.Interval:=100;
 timer.OnTimer:=Scrolltext;
 Fspeed:=3;
 FFont.Size := 14;
 FFont.Name := 'Times New Roman';
 FFont.Style := [fsBold];
 Fbgcolor:=clBlack;
 FFont.Color:=clred;
 Fpos:=pCenter;
 Canvas.Brush.Style := bsClear;
 Canvas.Font.Assign(FFont);
 timer.Enabled:=true;
 width:=200;
 height:=200;
 nowx:=0;
 nowy:=100000;
 canvas.Brush.Color:=Fbgcolor;
 Visible:=true;
end;destructor Tcwscrolltext.destroy;
begin
  timer.Free;
  Flines.Free;
  Fpicture.Free;
  inherited destroy;
end;end.