1 { 2 /*************************************************************************** 3 customtimer.pas 4 --------------- 5 Lazarus Component Library TCustomTimer 6 7 ***************************************************************************/ 8 9 ***************************************************************************** 10 This file is part of the Lazarus Component Library (LCL) 11 12 See the file COPYING.modifiedLGPL.txt, included in this distribution, 13 for details about the license. 14 ***************************************************************************** 15 } 16 unit CustomTimer; 17 18 {$mode objfpc}{$H+} 19 20 interface 21 22 uses 23 Classes, SysUtils, LCLProc, LCLStrConsts, LCLType, InterfaceBase; 24 25 type 26 27 { TCustomTimer } 28 29 TCustomTimer = class (TComponent) 30 private 31 FInterval : Cardinal; 32 FOnStartTimer: TNotifyEvent; 33 FOnStopTimer: TNotifyEvent; 34 FTimerHandle : THandle; 35 FOnTimer : TNotifyEvent; 36 FEnabled : Boolean; 37 procedure Timer; 38 protected 39 procedure SetEnabled(Value: Boolean); virtual; 40 procedure SetInterval(Value: Cardinal); virtual; 41 procedure SetOnTimer(Value: TNotifyEvent); virtual; 42 procedure DoOnTimer; virtual; 43 procedure UpdateTimer; virtual; 44 procedure KillTimer; virtual; 45 procedure Loaded; override; 46 public 47 constructor Create(AOwner: TComponent); override; 48 destructor Destroy; override; 49 property Enabled: Boolean read FEnabled write SetEnabled default True; 50 property Interval: Cardinal read FInterval write SetInterval default 1000; 51 property OnTimer: TNotifyEvent read FOnTimer write SetOnTimer; 52 property OnStartTimer: TNotifyEvent read FOnStartTimer write FOnStartTimer; 53 property OnStopTimer: TNotifyEvent read FOnStopTimer write FOnStopTimer; 54 end; 55 56 57 implementation 58 59 const 60 cIdNoTimer = THandle(-1); { timer ID for an invalid timer } 61 62 {------------------------------------------------------------------------------ 63 Method: TCustomTimer.Create 64 Params: AOwner: the owner of the class 65 Returns: Nothing 66 67 Constructor for a timer. 68 ------------------------------------------------------------------------------} 69 constructor TCustomTimer.Create(AOwner: TComponent); 70 begin 71 inherited Create(AOwner); 72 FInterval := 1000; 73 FTimerHandle := cIdNoTimer; 74 FEnabled := true; 75 end; 76 77 {------------------------------------------------------------------------------ 78 Method: TCustomTimer.Destroy 79 Params: Nothing 80 Returns: Nothing 81 82 Destructor for a timer. 83 ------------------------------------------------------------------------------} 84 destructor TCustomTimer.Destroy; 85 begin 86 FOnTimer:=nil; 87 FEnabled:=false; 88 KillTimer; 89 inherited Destroy; 90 end; 91 92 {------------------------------------------------------------------------------ 93 Method: TCustomTimer.KillTimer 94 Params: Nothing 95 Returns: Nothing 96 97 Kills the current timer object. 98 ------------------------------------------------------------------------------} 99 procedure TCustomTimer.KillTimer; 100 begin 101 if FTimerHandle <> cIdNoTimer then begin 102 //DebugLn(['TCustomTimer.KillTimer ',dbgsName(Self)]); 103 WidgetSet.DestroyTimer(FTimerHandle); 104 FTimerHandle := cIdNoTimer; 105 if Assigned(OnStopTimer) then OnStopTimer(Self); 106 end; 107 end; 108 109 procedure TCustomTimer.Loaded; 110 begin 111 inherited Loaded; 112 UpdateTimer; 113 end; 114 115 {------------------------------------------------------------------------------ 116 Method: TCustomTimer.UpdateTimer 117 Params: Nothing 118 Returns: Nothing 119 120 Updates the timer to match the current properties. 121 ------------------------------------------------------------------------------} 122 procedure TCustomTimer.UpdateTimer; 123 begin 124 KillTimer; 125 if (FEnabled) and (FInterval > 0) 126 and (([csLoading,csDestroying]*ComponentState=[])) 127 and Assigned (FOnTimer) then begin 128 //DebugLn(['TCustomTimer.UpdateTimer ',dbgsName(Self),' WidgetSet.CreateTimer']); 129 FTimerHandle := WidgetSet.CreateTimer(FInterval, @Timer); 130 if FTimerHandle=0 then begin 131 FTimerHandle:=cIdNoTimer; 132 raise EOutOfResources.Create(SNoTimers); 133 end; 134 if Assigned(OnStartTimer) then OnStartTimer(Self); 135 end; 136 end; 137 138 {------------------------------------------------------------------------------ 139 Method: TCustomTimer.Timer 140 Returns: Nothing 141 142 Is called when the timer has expired and calls users OnTimer function. 143 ------------------------------------------------------------------------------} 144 procedure TCustomTimer.Timer; 145 begin 146 {$IFDEF VerboseTimer} 147 DebugLn(['TCustomTimer.Timer ',dbgsName(Self),' ',FEnabled,' ',FInterval]); 148 {$ENDIF} 149 if (FEnabled) and (FInterval > 0) then 150 DoOnTimer; 151 end; 152 153 {------------------------------------------------------------------------------ 154 Method: TCustomTimer.SetOnTimer 155 Params: value - users notification function 156 Returns: Nothing 157 158 Assigns the users notification callback. 159 ------------------------------------------------------------------------------} 160 procedure TCustomTimer.SetOnTimer (value : TNotifyEvent); 161 begin 162 // Value=FOnTimer only compares code part 163 if CompareByte(Value,FOnTimer,SizeOf(Value))=0 then exit; 164 FOnTimer := value; 165 UpdateTimer; 166 end; 167 168 {------------------------------------------------------------------------------ 169 procedure TCustomTimer.DoOnTimer; 170 171 ------------------------------------------------------------------------------} 172 procedure TCustomTimer.DoOnTimer; 173 begin 174 if Assigned(FOnTimer) then 175 FOnTimer(Self); 176 end; 177 178 {------------------------------------------------------------------------------ 179 Method: TCustomTimer.SetEnabled 180 Params: value - new "enabled" state of the timer 181 Returns: Nothing 182 183 En/Disables the timer 184 ------------------------------------------------------------------------------} 185 procedure TCustomTimer.SetEnabled (value : boolean); 186 begin 187 if (Value <> FEnabled) then 188 begin 189 FEnabled := value; 190 UpdateTimer; 191 end; 192 end; 193 194 {------------------------------------------------------------------------------ 195 Method: TCustomTimer.SetInterval 196 Params: value - timer interval 197 Returns: Nothing 198 199 Sets interval for the timer. 200 ------------------------------------------------------------------------------} 201 procedure TCustomTimer.SetInterval (value : cardinal); 202 begin 203 if (value <> FInterval) then 204 begin 205 FInterval := value; 206 UpdateTimer; 207 end; 208 end; 209 210 end. 211