1 { 2 *************************************************************************** 3 * * 4 * This source is free software; you can redistribute it and/or modify * 5 * it under the terms of the GNU General Public License as published by * 6 * the Free Software Foundation; either version 2 of the License, or * 7 * (at your option) any later version. * 8 * * 9 * This code is distributed in the hope that it will be useful, but * 10 * WITHOUT ANY WARRANTY; without even the implied warranty of * 11 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * 12 * General Public License for more details. * 13 * * 14 * A copy of the GNU General Public License is available on the World * 15 * Wide Web at <http://www.gnu.org/copyleft/gpl.html>. You can also * 16 * obtain it by writing to the Free Software Foundation, * 17 * Inc., 51 Franklin Street - Fifth Floor, Boston, MA 02110-1335, USA. * 18 * * 19 *************************************************************************** 20 21 Author: Balázs Székely 22 } 23 unit opkman_timer; 24 25 {$mode objfpc}{$H+} 26 27 interface 28 29 uses 30 Classes, SysUtils; 31 32 type 33 { TThreadTimer } 34 TThreadTimer = class(TThread) 35 private 36 FTime: QWORD; 37 FInterval: Cardinal; 38 FOnTimer: TNotifyEvent; 39 FEnabled: Boolean; 40 procedure DoOnTimer; 41 protected 42 procedure Execute; override; 43 public 44 constructor Create; 45 destructor Destroy; override; 46 public 47 property OnTimer: TNotifyEvent read FOnTimer write FOnTimer; 48 property Interval: Cardinal read FInterval write FInterval; 49 property Enabled: Boolean read FEnabled write FEnabled; 50 procedure StopTimer; 51 procedure StartTimer; 52 end; 53 54 implementation 55 56 { TThreadTimer } 57 58 constructor TThreadTimer.Create; 59 begin 60 inherited Create(True); 61 FreeOnTerminate := True; 62 FInterval := 1000; 63 FEnabled := False; 64 end; 65 66 destructor TThreadTimer.Destroy; 67 begin 68 // 69 inherited Destroy; 70 end; 71 72 procedure TThreadTimer.DoOnTimer; 73 begin 74 if Assigned(FOnTimer) then 75 FOnTimer(Self); 76 end; 77 78 procedure TThreadTimer.Execute; 79 begin 80 while not Terminated do 81 begin 82 Sleep(100); 83 if (GetTickCount64 - FTime > FInterval) and (FEnabled) then 84 begin 85 FTime := GetTickCount64; 86 DoOnTimer; 87 end; 88 end; 89 end; 90 91 procedure TThreadTimer.StopTimer; 92 begin 93 FEnabled := False; 94 end; 95 96 procedure TThreadTimer.StartTimer; 97 begin 98 FTime := GetTickCount64; 99 FEnabled := True; 100 if Self.Suspended then 101 Start; 102 end; 103 104 end. 105 106