unit tspinningglobe; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,stdctrls,extctrls; type TSpinGlobeThread = class (TThread) private { Private declarations } fupdateproc : TNotifyEvent; protected procedure Execute; override; procedure Update; public property UpdateProc : TNotifyEvent write fupdateproc; end; type TSpinGlobe = class(TCustomControl) private updatethread : TSpinGlobeThread; count : integer; o : tbitmap; a : hrgn; { Private declarations } protected { Protected declarations } public h : thandle; fpp : pointer; constructor Create(AOwner : TComponent); override; destructor Destroy;override; procedure advance(Sender : Tobject); procedure start; procedure stop; procedure Paint; override; procedure Resize; override; { Public declarations } published { Published declarations } end; procedure Register; implementation {$R spinglobe.RES} constructor TSpinglobe.Create(AOwner : TComponent); begin o:=tbitmap.create; inherited Create (AOwner); Parent := (AOwner AS TWinControl); // controlstyle:=controlstyle-[csOpaque]; width:=152; height:=152; count:=0; o.width:=width; o.height:=height; advance(self); paint; updatethread:=TSpinGlobeThread.Create(true); updatethread.FreeOnTerminate:=true; updatethread.UpdateProc:=advance; end; destructor TSpinglobe.Destroy(); begin o.free; inherited Destroy; updatethread.Terminate; if updatethread.Terminated=false then updatethread.WaitFor; end; procedure TSpinglobe.Paint; begin if parent=nil then exit; inherited paint; canvas.Draw(0,0,o); end; procedure Tspinglobe.advance; begin if self=nil then exit; inc(count); if count>9 then count:=1; o.LoadFromResourceName(hinstance,'G'+inttostr(count)); paint; end; procedure Register; begin RegisterComponents('LibrarySmith', [TSpinGlobe]); end; procedure TSpinglobe.start; begin visible:=true; if updatethread.Suspended then updatethread.Resume; end; procedure TSpinglobe.stop; begin visible:=false; if updatethread.Suspended=false then updatethread.Suspend; end; procedure Tspinglobe.Resize(); begin a:=CreateEllipticRgn(1,1, Width, Height); if a<>0 then begin setwindowrgn(self.handle ,a,true); end; end; procedure TSpinGlobeThread.Update; begin fupdateproc(self); end; procedure TSpinGlobeThread.Execute; var n : integer; begin n:=0; while 1<2 do begin inc(n); if n=5 then begin synchronize(Update); sleep(100); if terminated=true then exit; n:=0; end; end; end; end.