Delphi知识中心
www.delphi.ee
提供Delphi技术知识
与Delphi程序员共同进步


在线服务QQ:99923144 随时恭候您的光临
首页 基础知识 WIN系统 组件使用 组件开发 数据库 ACTIVEX 多媒体技术 网络技术 关于
文章类别:组件开发    你尚未登陆,会员功能无法使用,请从 网站首页 登陆。
  文字滚屏控件(SliderPanel)  
 
文字滚屏控件(SliderPanel)

{
关于SliderPanel:

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

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

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


}

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 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 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 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.

 

在线服务QQ:99923144 Delphi程序员QQ群(139442)
Delphi知识中心 www.delphi.ee 最专业的Delphi技术资料网站