文字滾屏控件(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事件，這樣每次從頭顯示時可以進行一些必要處理，比如重新設定
3，提供背景文字，在屬性Caption中設置，其樣式由CaptionStyle屬性控制。
4，文字滾動速度由屬性ScrollSpeed控制，單位是毫秒。
5，文字的對齊方式可以由Alignment屬性控制。
6，文字可以自動換行。
感謝滿天星共享軟件註冊服務中心（http://www.star-reg.com/）在我發布軟件時對
我的幫助，特此自願冠名發布。
歡迎各位傳播、使用和修改本控件，但是務必請保留本處的所有說明信息。如果您有
什麽改進的地方，也歡迎您提供一份新的拷貝給我，謝謝！
本人聯系方式： [email protected]
}
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;
if assigned(FOnChange) then FonChange(Self);
FDealStrings := false;
//
toPAINTtxt;
end;
{ **************************************************************************** }
end.
（出處：DelphiFans.com）
文字滾屏控件(SliderPanel)