程序代碼如下所示：

unit SliderMemo;

interface

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

type
　TSliderMemo = class(TMemo)
　private
　　FOnLoop:TNotifyEvent;
　　FTopNow:integer;
　　FScrollSpeed: integer;
　　FTimer: TTimer;
　　FCanvas :TControlCanvas;
　　procedure SetScrollSpeed (Value: integer);
　　procedure wmPAINT(var Message: TMessage); message WM_PAINT;
　　procedure WMEraseBkgnd(var Message: TWMEraseBkgnd); message WM_ERASEBKGND;
　　procedure toPAINT;
　　procedure Timer(Sender: TObject);
　protected
　　procedure KeyDown(var Key: Word;　Shift: TShiftState); override;
　　procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
　public
　　constructor Create (AOwner: TComponent); override;
　　destructor　Destroy ; override;
　　Procedure　 Start;
　　Procedure　 Stop;
　published
　　property ScrollSpeed: integer read FScrollSpeed write SetScrollSpeed default 10;
　　property OnLoop: TNotifyEvent read FOnLoop write FOnLoop;
　end;

procedure Register;

implementation
var
　　　Initial:boolean;
　　　TxtHeight:integer;


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

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

procedure TSliderMemo.wmPAINT(var Message: TMessage);// Repaint the control ...
begin

　　　inherited;
　　　toPaint;

end;

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

procedure TSliderMemo.toPAINT;
var
　offset,Offset1,iLoop:integer;
begin

　　　if self.Focused then
　　　begin
　　　　 self.SelLength := 0;
　　　　 postmessage(self.Handle,WM_KILLFOCUS,0,0);　//非常重要
　　　end;

　　　if Initial then
　　　begin
　　　　　OffSet := height - FTopNow;
　　　　　FCanvas.FillRect(self.ClientRect);//rect(1,1,));
　　　　　for iLoop:=0 to self.Lines.Count - 1 do
　　　　　begin
　　　　　　　OffSet1 := OffSet + TxtHeight;
　　　　　　　if (OffSet1>0) and (OffSet<height) then
　　　　　　　　　FCanvas.textout(1,OffSet,self.Lines[iLoop]);
　　　　　　　OffSet := OffSet1;
　　　　　end;
　　　end;
end;
{ **************************************************************************** }

procedure TSliderMemo.Timer(Sender: TObject);
begin
　if not Initial then
　begin
　　 FCanvas.Font := self.Font;
　　 self.Font.Color := self.Color;
　　 FTopNow := self.Height;
　　 TxtHeight := FCanvas.textheight('Pj');
　　 self.TabStop := false;
　　 FCanvas.Brush.Color := self.Color;
　　 start;
　　 Initial := true;
　end;
　toPaint;

　FTopNow := FTopNow + 1;
　if FTopNow>(height+TxtHeight*Self.Lines.Count) then
　begin
　　FTopNow :=0;
　　if assigned(FOnLoop) then
　　begin
　　　 Stop;
　　　 FOnLoop(Self);
　　　 Start;
　　end;
　end;

end;

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

procedure TSliderMemo.Stop;
begin
　 FTimer.Enabled := False;
end;
{ **************************************************************************** }

procedure TSliderMemo.Start;
begin
　 FTimer.Enabled := true ;
end;

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

constructor TSliderMemo.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;

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

　FCanvas := TControlCanvas.Create;
　FCanvas.Control := self;

　toPaint;
　//ShowMessage(inttostr(FTImer.Interval) + '　' + inttostr(FScrollSpeed) + '　 topnow' + inttostr(FTopNow));

end;

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

destructor　TSliderMemo.Destroy;
begin
　 FTimer.free;
　 FCanvas.Free;
　 inherited;
end;

{ **************************************************************************** }
procedure TSliderMemo.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 TSliderMemo.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
　　 inherited MouseDown(Button,Shift,X, Y);
　　 toPaint;
end;

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

procedure TSliderMemo.KeyDown(var Key: Word;Shift: TShiftState);
begin
　　 inherited KeyDown(key,Shift);
　　 toPaint;
end;

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

procedure TSliderMemo.WMEraseBkgnd(var Message: TWMEraseBkgnd);
begin
　　// 不要重繪背景，這會造成構件閃動
　　Message.Result := 0;
end;


end.


標簽：