Delphi在控件中添加字符滾動的消息處理功能

Delphi 在控件中添加字符滾動的消息處理功能，讓字符附著在控件內，並加上滾動的功能，Delphi初學者可參考，運行效果圖：

具體實現代碼如下：Unit1.pas代碼

01 unit Unit1; 02 interface 03 uses 04   Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, 05   Dialogs, StdCtrls,QExtCtrls, ExtCtrls, ScrollHint; 06 type 07   TForm1 = class(TForm) 08     ScrollHint1: TScrollHint; 09     Button1: TButton; 10     procedure Button1Click(Sender: TObject); 11   private 12     { Private declarations } 13   public 14     { Public declarations } 15   end; 16 var 17   Form1: TForm1; 18 implementation 19 {$R *.dfm} 20 procedure TForm1.Button1Click(Sender: TObject); 21 begin 22   if button1.Caption='開始' then 23     begin 24     button1.Caption:='停止'; 25     scrollhint1.BeginScroll; 26     end 27   else 28     begin 29     button1.Caption:='開始'; 30     scrollhint1.EndScroll; 31     end; 32 end; 33 end.

ScrollHint.pas代碼：

vIEw source print? 001 unit ScrollHint; 002 interface 003 uses 004   Windows, Messages, SysUtils, Classes, Controls, 005   ExtCtrls, Graphics; 006 type 007   TScrollHint = class(TCustomControl) 008   private 009     { Private declarations } 010     FVal:LongInt; 011     FTimer:TTimer; 012     FScrollEnabled:Boolean; 013     FText:widestring; 014     FTempText:widestring; 015     Captured: Boolean; 016     procedure WmMouseMove (var Msg:TWMMouse); message wm_MouseMove; 017     function GetFont:TFont; 018     procedure SetFont(f:TFont); 019     procedure SetInterVal(AInterVal:LongInt); 020     procedure SetScrollEnabled(Enabled:Boolean); 021     procedure SetText(Text:widestring); 022     procedure TimesUp(Sender:TObject); 023   protected 024     { Protected declarations } 025     Procedure Paint; override; 026   public 027     { Public declarations } 028     constructor Create(AOwner: TComponent); override; 029     destructor Destroy; override; 030     procedure BeginScroll; 031     Procedure EndScroll; 032   published 033     { Published declarations } 034     property Font:TFont read GetFont write SetFont; 035     Property InterVal:LongInt read FVal write SetInterVal default 100; 036     property ScrollEnabled:Boolean read FScrollEnabled write SetScrollEnabled default False; 037     property Text:widestring read FText write SetText; 038   end; 039 procedure Register; 040 implementation 041 procedure Register; 042 begin 043   RegisterComponents('Samples', [TScrollHint]); 044 end; 045 function TScrollHint.GetFont:TFont; 046 begin 047   Result:=Canvas.Font; 048 end; 049 procedure TScrollHint.SetFont(f:TFont); 050 begin 051   Canvas.Font:=f; 052 end; 053 procedure TScrollHint.SetInterVal(AInterVal:LongInt); 054 begin 055   FVal:=AInterVal; 056   if Assigned(FTimer) then FTimer.Interval:=AInterVal; 057 end; 058 procedure TScrollHint.SetScrollEnabled(Enabled:Boolean); 059 begin 060   if Enabled then BeginScroll 061   else EndScroll; 062 end; 063 procedure TScrollHint.SetText(Text:widestring); 064 var 065   t:Boolean; 066 begin 067   t:=FScrollEnabled; 068   if t then FTimer.Enabled:=False; 069   FText:=Text; 070   FTempText:=Text; 071   Paint; 072   if t then FTimer.Enabled:=True; 073 end; 074 procedure TScrollHint.TimesUp(Sender:TObject); 075 var 076   head:widestring; 077 begin 078   Paint; 079   head:=Copy(FTempText,1,1); 080   FTempText:=Copy(FTempText,2,length(FTempText)-1)+head; 081 end; 082 Procedure TScrollHint.Paint; 083 begin 084   Canvas.TextOut(0,0,FTempText); 085 end; 086 procedure TScrollHint.WmMouseMove (var Msg:TWMMouse); 087 begin 088   inherited; 089   if not ScrollEnabled then exit; 090   if not Captured then 091     begin 092     SetCapture(Handle); 093     Captured:=True; 094     FTimer.Enabled:=False; 095     end 096   else 097     if (Msg.XPos < 0) or (Msg.XPos > Width) 098         or (Msg.YPos < 0) or (Msg.YPos > Height) then 099       begin 100       Captured:=False; 101       ReleaseCapture; 102       FTimer.Enabled:=True; 103       end; 104 end; 105 constructor TScrollHint.Create(AOwner: TComponent); 106 begin 107   inherited Create(AOwner); 108   FVal:=100; 109   FTimer:=TTimer.Create(Parent); 110   FTimer.Interval:=FVal; 111   FTimer.Enabled:=False; 112   FTimer.OnTimer:=TimesUp; 113   FScrollEnabled:=False; 114   Captured:=False; 115 end; 116 destructor TScrollHint.Destroy; 117 begin 118   FTimer.Free; 119   FTimer:=nil; 120   inherited Destroy; 121 end; 122 procedure TScrollHint.BeginScroll; 123 begin 124   FTempText:=FText; 125   FScrollEnabled:=True; 126   FTimer.Enabled:=True; 127 end; 128 Procedure TScrollHint.EndScroll; 129 begin 130   FScrollEnabled:=False; 131   FTimer.Enabled:=False; 132 end; 133 end.