求购滚屏软件的源代码，分不够可以再加

Question

unit Unit1;interfaceuses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  ExtCtrls, StdCtrls;type
  TForm1 = class(TForm)
    Memo1: TMemo;
    Timer1: TTimer;
    Image1: TImage;
    procedure FormCreate(Sender: TObject);
    procedure Timer1Timer(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;var
  Form1: TForm1;implementation{$R *.DFM}
var
  MaxTxtHeight, Y: Integer;procedure TForm1.Timer1Timer(Sender: TObject);
var
  I: Integer;
  TxtLinePosY: Integer;
begin
  Image1.Canvas.FillRect(Image1.ClientRect);
  TxtLinePosY := Y;
  for I := 0 to Memo1.Lines.Count - 1 do
  begin
    Inc(TxtLinePosY, MaxTxtHeight);
    if (TxtLinePosY < -MaxTxtHeight) or (TxtLinePosY > Image1.ClientHeight) then
      Continue
    else
      Image1.Canvas.TextOut(0, TxtLinePosY, Memo1.Lines[I]);
  end;
  Dec(Y);
  if Y < -Memo1.Lines.Count * MaxTxtHeight then
    Y := Image1.ClientHeight;
end;procedure TForm1.FormCreate(Sender: TObject);
begin
  Image1.Canvas.Brush.Color := Color;
  MaxTxtHeight := Image1.Canvas.TextWidth('gh');
  Y := Image1.ClientHeight;
end;end.//可以满足一般要求，试试就知道了

Answer 1

好累啊。是不是有专用组件呢？UPUP

Answer 2

双缓冲！twincontrol的继承类都有这个属性！实现平滑移动！

Answer 3

呵呵，我前一段时间问了很久，现在知道答案了，要的留下email
另外，cobi，我已经发到你的机器上去了

Answer 4

//变态方法仅供参考
procedure TForm1.Timer1Timer(Sender: TObject);
begin
  Label1.Top := Label1.Top - 1;
end;procedure TForm1.FormCreate(Sender: TObject);
begin
  Label1.Top := 1;
  Label1.Left := 1;
  Label1.AutoSize := False;
  Label1.Width := Memo1.Width - 2;
  Label1.Height := Memo1.Height * 2;
  Label1.Parent := Memo1;
  Timer1.Interval := 10;
  CheckBox1.Checked := False;
  CheckBox1Click(CheckBox1);
end;procedure TForm1.CheckBox1Click(Sender: TObject);
begin
  Label1.Top := 1;
  Timer1.Enabled := TCheckBox(Sender).Checked;
  Label1.Visible := TCheckBox(Sender).Checked;
  Label1.Caption := Memo1.Text;
  Label1.WordWrap := Memo1.WordWrap;
end;

Answer 5

楼上的，呵呵，不会是在我的贴子里面把zswang(伴水)提供的变太方法给拷贝过来吧？？？
这种方法业想得出来，太不可行了吧？？

Answer 6

to 962veiri(风尘旅人) 
[email protected]
先谢谢了。要分只管说一声，呵呵！！

Answer 7

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);
//    procedure WndProc(var Msg: TMessage);override;
  protected
    { Protected declarations }
    destructor Destroy; override;
  public
    { Public declarations }
//    procedure ShowAbout;Virtual;
    constructor Create(aOwner : TComponent); override;
    procedure Paint;override;
  published
    { Published declarations }
//    property About: string read FAbout write FAbout stored False;
    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;
{type
  TAboutProperty = class(TPropertyEditor)
  public
    procedure Edit; override;
    function GetAttributes: TPropertyAttributes; override;
    function GetValue:string; override;
  end;
}
procedure Register;implementation{$R scrolltext.res}
{
procedure TAboutProperty.Edit;
begin
  TcwScrolltext(GetComponent(0)).ShowAbout;
end;function TAboutProperty.GetValue:string;
begin
   result:='cwScrolltext v1.0';
end;function TAboutProperty.GetAttributes: TPropertyAttributes;
begin
  GetAttributes := [paDialog, paReadOnly];
end;procedure TcwScrolltext.ShowAbout;
var msg:string;
const cr = #13#10;
begin
  msg   := ' TcwScrollText V1.0' + cr+cr;
  msg:=msg+' This component is free '+cr;
  msg:=msg+' Use it as you like'+cr;
  msg:=msg+' If you found bugs,Tell me.'+cr;
  msg:=msg+' But if you changed or improved it'+cr;
  msg:=msg+' Please Let me known !!!'+cr+cr;
  msg:=msg+' Enjoy it :-)';
  MessageDlg(msg,mtInformation,[MBOK],0);
end;
}
procedure Register;
begin
  RegisterComponents('Chen wei', [TcwScrollText]);
//  RegisterPropertyEditor(TypeInfo(String), TcwScrolltext, 'About',
//     TAboutProperty);
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;
//     Timer.Enabled:=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;{procedure TcwScrolltext.WndProc(var Msg: TMessage);
var p:Tpoint;
begin
   inherited wndproc(msg);
   case msg.msg of
        WM_LBUTTONDBLCLK:if assigned(FOnDblClick) then FOnDblClick(self);
        WM_LBUTTONUP:    if assigned (FOnClick) then FOnClick(self);
        WM_RBUTTONUP:begin
                       getcursorpos(p);
                       if assigned (FOnRightClick) then FOnRightClick(self,mbRight,[],p.x,p.y);
                     end;
   end;
   inherited wndproc(msg);
end;
}
end.
一个控件的源代码。
可以添加文字，和图片。大家可以优化它。还有点小bug，就是字体颜色在运行期不能改变，我没有管他，还是留给大家自己改吧

Answer 8

keani(基恩)　
我的网络速度太慢，所以只能给源代码，请谅解！！

Answer 9

hhhappy(快乐)　的好像只是一行就可以
多行不行？

Answer 10

[email protected]
邮件已经发送，收到了码？分数？ ~o~

Answer 11

还有，没收到，请在寄往  [email protected]  thankz！！

Answer 12

能寄我一份吗？　[email protected]
重谢

Answer 13

要的请留下email
省得我每次都要发一次email，^u^

Answer 14

xueyin(雪莹):
    发给你了，快去收邮件，满意的话，不要忘了给分。8-0

Answer 15

xueyin(雪莹):怎么发布到你那里去？？？
说我邮件传输失败！！我再发一次！

Answer 16

还是没法成功，你的email是不是错的？？？

Answer 17

xinfei(aw)： xueyin(雪莹)　：
同一个人？？？
邮件发过去了（成功发送），如果满意的话，给分 ^u^,谢谢啦 

Answer 18

我写了一个完整的示例程序，现在贴上来给你。//main.pasunit main;
interface
uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  ExtCtrls;
type
  TForm1 = class(TForm)
    PaintBox1: TPaintBox;
    Timer1: TTimer;
    procedure FormCreate(Sender: TObject);
    procedure Timer1Timer(Sender: TObject);
    procedure PaintBox1Paint(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;var
  Form1: TForm1;
  Y:integer;
implementation{$R *.DFM}procedure TForm1.FormCreate(Sender: TObject);
begin
    y:=paintbox1.Height;
end;procedure TForm1.Timer1Timer(Sender: TObject);
begin
  PaintBox1.Canvas.Font.Color := clBlue;
  PaintBox1.Canvas.TextOut(50,y,'这是平滑滚屏示例');
  PaintBox1.Canvas.Font.Color := clBlack;
  PaintBox1.Canvas.TextOut(60,y+PaintBox1.Canvas.Font.Size+8,'效果还不错吧');
  dec(y);
  if y<-(PaintBox1.Canvas.Font.Size+8)*2 then y:=paintbox1.Height;
end;procedure TForm1.PaintBox1Paint(Sender: TObject);
begin
    PaintBox1.Canvas.Font.Name:='宋体';
    PaintBox1.Canvas.Font.Size:=10;
    PaintBox1.Canvas.Brush.Color := clwhite;
    PaintBox1.Canvas.FillRect(Rect(0,0,PaintBox1.Width, PaintBox1.Height));
end;
end.
//main.dfm
object Form1: TForm1
  Left = 209
  Top = 142
  Width = 214
  Height = 202
  Caption = 'Form1'
  Color = clBtnFace
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clWindowText
  Font.Height = -11
  Font.Name = 'MS Sans Serif'
  Font.Style = []
  OldCreateOrder = False
  Position = poScreenCenter
  OnCreate = FormCreate
  PixelsPerInch = 96
  TextHeight = 13
  object PaintBox1: TPaintBox
    Left = 0
    Top = 0
    Width = 206
    Height = 175
    Align = alClient
    OnPaint = PaintBox1Paint
  end
  object Timer1: TTimer
    Interval = 50
    OnTimer = Timer1Timer
    Left = 152
    Top = 128
  end
end

Answer 19

//同意hhhappy(快乐)　
procedure TForm1.FormCreate(Sender: TObject);
begin
  DoubleBuffered := True; //for Delphi6
  MaxTxtHeight := Image1.Canvas.TextWidth('gh');
  Y := Image1.ClientHeight;
  Image1.Transparent := True; //可以加个背景，很不错！！！
  Timer1.Interval := 50;
  Timer1.Enabled := True;
end;