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, CustApp; 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 try 151 DoOnTimer; 152 except 153 CustomApplication.HandleException(nil); 154 end; 155 end; 156 157 {------------------------------------------------------------------------------ 158 Method: TCustomTimer.SetOnTimer 159 Params: value - users notification function 160 Returns: Nothing 161 162 Assigns the users notification callback. 163 ------------------------------------------------------------------------------} 164 procedure TCustomTimer.SetOnTimer (value : TNotifyEvent); 165 begin 166 // Value=FOnTimer only compares code part 167 if CompareByte(Value,FOnTimer,SizeOf(Value))=0 then exit; 168 FOnTimer := value; 169 UpdateTimer; 170 end; 171 172 {------------------------------------------------------------------------------ 173 procedure TCustomTimer.DoOnTimer; 174 175 ------------------------------------------------------------------------------} 176 procedure TCustomTimer.DoOnTimer; 177 begin 178 if Assigned(FOnTimer) then 179 FOnTimer(Self); 180 end; 181 182 {------------------------------------------------------------------------------ 183 Method: TCustomTimer.SetEnabled 184 Params: value - new "enabled" state of the timer 185 Returns: Nothing 186 187 En/Disables the timer 188 ------------------------------------------------------------------------------} 189 procedure TCustomTimer.SetEnabled (value : boolean); 190 begin 191 if (Value <> FEnabled) then 192 begin 193 FEnabled := value; 194 UpdateTimer; 195 end; 196 end; 197 198 {------------------------------------------------------------------------------ 199 Method: TCustomTimer.SetInterval 200 Params: value - timer interval 201 Returns: Nothing 202 203 Sets interval for the timer. 204 ------------------------------------------------------------------------------} 205 procedure TCustomTimer.SetInterval (value : cardinal); 206 begin 207 if (value <> FInterval) then 208 begin 209 FInterval := value; 210 UpdateTimer; 211 end; 212 end; 213 214 end. 215