文字滚屏控件(SliderPanel)

http://www.delphifans.com/infoview/Article_629.html

日期：2005年9月6日作者：arhaha

{
==================== 满天星共享软件注册服务中心申明 ======================
本软件由满天星共享软件注册服务中心（http://www.star-reg.com/）赞助冠名发布，
目的在于促进技术交流，促进中国软件产业的发展与进步。

本软件的版权以及其他所有权益归原作者所有，满天星共享软件注册服务中心不承担
任何由本软件的发布带来的权益纠纷和责任。

欢迎软件作者加盟满天星共享软件注册服务中心（http://www.star-reg.com/），为
民族软件产业的发展而共同努力！！
===========================================================================
}

{
关于SliderPanel:

一个文字滚屏控件，可以用作系统的新任务或者消息提示。

这是本人两年前在做一个项目时的产物，参照了一个外国的控件，具体是什么控件现
在想不起来了。但是本人可以保证，其中很大的部分代码都是我自己重新写的。当时
刚刚开始做控件，写得不怎么样，不过可以给初学者提供一个如何写控件的学习样例。

本控件的特点：
   1，在Panel面板上滚动由Lines属性提供的任何文字信息。
   2，提供OnLoop事件，这样每次从头显示时可以进行一些必要处理，比如重新设定
      Lines属性的值。
   3，提供背景文字，在属性Caption中设置，其样式由CaptionStyle属性控制。
   4，文字滚动速度由属性ScrollSpeed控制，单位是毫秒。
   5，文字的对齐方式可以由Alignment属性控制。
   6，文字可以自动换行。

感谢满天星共享软件注册服务中心（http://www.star-reg.com/）在我发布软件时对
我的帮助，特此自愿冠名发布。

欢迎各位传播、使用和修改本控件，但是务必请保留本处的所有说明信息。如果您有
什么改进的地方，也欢迎您提供一份新的拷贝给我，谢谢！

本人联系方式： arlinfd@etang.com

}

unit SliderPanel;

interface

uses Windows, Messages, SysUtils, Classes, Graphics,Controls,StdCtrls,Dialogs,
ExtCtrls,StrUtils,forms;

type
TCaptionStyle = (csNormal,csHollow,csShadow);
TSliderPanel = class(TPanel)
private
    FOnLoop:TNotifyEvent;
    FOnChange:TNotifyEvent;
    FTopNow:integer;
    FScrollSpeed: integer;
    FTimer: TTimer;
    FLines: TStringList;
    FDealStrings:boolean;
    FAlignment :TAlignment;
    FCaptionStyle :TCaptionStyle;
    FActive :Boolean;

    Initial:boolean;
    TxtHeight:integer;
    FXOffSet :array of integer;

    procedure SetLines (Value: TStringList);
    procedure SetCaptionStyle (Value: TCaptionStyle);
    procedure SetActive (Value: boolean);
    procedure SetAlignment (Value: TAlignment);
    procedure SetScrollSpeed (Value: integer);
    procedure Timer(Sender: TObject);
    procedure LinesChanged(Sender: TObject);
    procedure toPAINTtxt;
protected
    procedure Resize;override;
    procedure Paint;OverRide;
public
    constructor Create (AOwner: TComponent); override;
    destructor Destroy ; override;
published
    property Active: Boolean read FActive write SetActive default true;
    property CaptionStyle: TCaptionStyle read FCaptionStyle write SetCaptionStyle default csNormal;
    property Alignment: TAlignment read FAlignment write SetAlignment default taLeftJustify;

property Lines: TStringList read FLines write SetLines;

    //文字滚动速度控制，单位是毫秒
    property ScrollSpeed: integer read FScrollSpeed write SetScrollSpeed default 10;
    property OnLoop: TNotifyEvent read FOnLoop write FOnLoop;
end;

procedure Register;

implementation

Const
constStopMess :String = '已经停止滚动！';

procedure Register;
begin
RegisterComponents('Arhaha', [TSliderPanel]);
showmessage('The TSliderPanel component is made by Arhaha 2002-07');
end;

{ **************************************************************************** }

procedure TSliderPanel.paint;
var
   OutMess:string;
begin
      //*******
      //inherited;

      SetBKMode(canvas.Handle,windows.TRANSPARENT);
      //
      if self.FTimer.enabled then
         OutMess :=Caption
      else
         OutMess :=constStopMess;

canvas.Brush.Color := self.Color;
Canvas.FillRect(self.ClientRect);

      canvas.Font.name := '宋体';
      canvas.Font.Size := self.Font.Size + 16;
      canvas.Font.Style := [fsBold,fsItalic];
      if FCaptionStyle = csHollow then
      begin
         beginpath(canvas.handle);
         SetBkMode( Canvas.Handle, TRANSPARENT );
      end;
      if FCaptionStyle = csShadow then
      begin
         canvas.Font.Color := cl3DDKShadow;
         canvas.TextOut((self.Width - canvas.TextWidth(OutMess)) * 5 div 11 + 1,(self.height - canvas.Textheight(OutMess)) div 2 + 1,OutMess);
      end;
      canvas.Font.Color := clBtnFace;
      canvas.TextOut((self.Width - canvas.TextWidth(OutMess)) * 5 div 11,(self.height - canvas.Textheight(OutMess)) div 2,OutMess);
      if FCaptionStyle = csHollow then
      begin
          endpath(canvas.handle);
          Canvas.Pen.Color := clBtnFace;
          StrokePath(canvas.handle); //将捕获的轮廓用当前的Pen画到Canvas上
      end;

canvas.Font := self.Font;

toPAINTtxt;

end;

{ **************************************************************************** }

procedure TSliderPanel.toPAINTtxt;// Repaint the control ...
var
YOffset,YOffset1,iLoop:integer;
     OutMess:string;
begin
      if FDealStrings then exit;
      if Initial and (self.Lines.Count = high(FXOffSet)+1) then
      begin
          YOffSet := height - FTopNow;
          for iLoop:=0 to self.Lines.Count - 1 do
          begin
              YOffSet1 := YOffSet + TxtHeight;
              if (YOffSet1>0) and (YOffSet<height) then
                  Canvas.textout(FXOffSet[iLoop],YOffSet,self.Lines[iLoop]);
              YOffSet := YOffSet1;
          end;
      end;
end;
{ **************************************************************************** }

procedure TSliderPanel.Timer(Sender: TObject);
begin
if not Initial then
begin
     Canvas.Font := self.Font;
     FTopNow := self.Height;
     TxtHeight := Canvas.textheight('Pg哈');
     self.TabStop := false;
     Canvas.Brush.Color := self.Color;

Initial := true;
end else
invalidate;

FTopNow := FTopNow + 1;
if FTopNow>(height+TxtHeight*Self.Lines.Count) then
begin
    FTopNow :=0;
    if assigned(FOnLoop) then
    begin
       FTimer.Enabled := false;
       FOnLoop(Self);
       FTimer.Enabled := true;
    end;
end;
end;

{ **************************************************************************** }

procedure TSliderPanel.SetCaptionStyle (Value: TCaptionStyle);
begin
   if FCaptionStyle <> value then
   begin
      FCaptionStyle := value;
      invalidate;
   end;
end;

{ **************************************************************************** }

procedure TSliderPanel.SetActive (Value: boolean);
begin
   if FActive <> value then
   begin
        FActive := value;
        FTimer.Enabled := value;
        invalidate;
   end;
end;

{ **************************************************************************** }

constructor TSliderPanel.Create (AOwner: TComponent);
begin
inherited Create (AOwner);
ControlStyle := ControlStyle + [csOpaque];

FScrollSpeed :=50;
FTimer := TTimer.create(self);
FTImer.Interval :=FScrollSpeed;// ;
FTimer.ontimer := timer;
Initial := false;
self.Cursor := crArrow;
FLines := TStringList.Create;
FLines.onchange := LinesChanged;
FActive := true;
BevelOuter := bvNone;
BevelInner := bvNone;
BorderStyle := bsSingle;

if (FTimer.Interval<1) or (csDesigning in ComponentState) then
begin
//FTimer.Enabled := false;
end;

end;

{ **************************************************************************** }

destructor TSliderPanel.Destroy;
begin
   FTimer.free;
   FLines.Free;
   inherited;
end;

{ **************************************************************************** }
procedure TSliderPanel.SetScrollSpeed (Value: integer);
begin
if value>=0 then
begin
    FScrollSpeed := Value;
    FTimer.Interval := value;
    Refresh;
end else
    ShowMessage('ScrollSpeed must be greater than -1!');
end;

{ **************************************************************************** }

procedure TSliderPanel.SetLines (Value: TStringList);
begin
FLines.Assign(value);
end;

{ **************************************************************************** }

procedure TSliderPanel.SetAlignment(Value: TAlignment);
begin
    if FAlignment <> value then
    begin
      FAlignment := value;
      LinesChanged(self);
      refresh;
    end;
end;

{ **************************************************************************** }

procedure TSliderPanel.ReSize;
var
   iLoop:integer;
begin
   inherited ReSize;
   iLoop := TxtHeight + 10;
   if (self.Height<iLoop) or (self.Width < iLoop) then exit;
   FDealStrings := true;
   for iLoop :=1 to self.Lines.Count - 1 do
   begin
       if (csDesigning in ComponentState) and ((rightstr(self.Lines[0],1)<>#10)) or (length(self.Lines[1])=0) then
          self.Lines[0] := self.Lines[0]+#13#10 + self.Lines[1]
       else
          self.Lines[0] := self.Lines[0] + self.Lines[1];

       self.Lines.Delete(1);
   end;
   FDealStrings := false;
   LinesChanged(self);
end;

{ **************************************************************************** }

procedure TSliderPanel.LinesChanged(Sender: TObject);
var
   iLoop,iInnerLoop,iPos,iWidth:integer;
   anstr:widestring;
   temps:string;
begin
   //
   if FDealStrings then exit;

   FDealStrings := true;
   //////处理换行符
   iLoop:=0;
   while iLoop < self.Lines.Count do
   begin
       temps := self.Lines[iLoop];
       iPos := pos(#13#10,temps);
       inc(iLoop);
       if (iPos>0) and ((iPos + 1) < length(temps)) then
       begin
          self.Lines[iLoop - 1]:=leftstr(temps,iPos + 1);
          self.Lines.Insert(iLoop,rightstr(temps,length(temps) -iPos -1));
       end;
   end;

   iLoop := 0;
   while iLoop<self.Lines.Count do
   begin
       anstr := widestring(self.Lines[iLoop]);
       inc(iLoop);
       if canvas.TextWidth(anstr)>self.ClientWidth then
       begin
          iWidth := 0;
          for iInnerLoop := 1 to length(anstr) do
          begin
             if anstr[iInnerLoop]=#13 then break;
             iWidth := iWidth + self.Canvas.TextWidth(anstr[iInnerLoop]);
             if (iWidth > self.ClientWidth) then
             begin
                 temps := '';
                 for iPos :=1 to iInnerLoop -1 do temps := temps + anstr[iPos];
                 self.Lines[iLoop - 1] := temps;

                 temps := '';
                 for iPos := length(anstr) downto iInnerLoop do temps := anstr[iPos] + temps;
                 self.Lines.Insert(iLoop,temps);
                 break;
             end;
          end;
       end;
   end;

   /////计算显示位置的X位移
   iPos := self.Lines.Count;
   if iPos>0 then
   begin
       setlength(FXOffSet,iPos);
       //self.Canvas.TextOut(100,100,'aaaa');
       for iLoop :=0 to iPos -1 do
       begin
           iWidth := self.Canvas.TextWidth( self.Lines[iLoop]);
           if FAlignment = taLeftJustify then
           begin
              FXOffSet[iLoop] := 0;
           end else if FAlignment = taRightJustify then
           begin
              FXOffSet[iLoop] :=self.ClientWidth - iWidth;
           end else
           begin
              FXOffSet[iLoop] := (self.ClientWidth - iWidth) div 2;
           end;
       end;
   end;