ich habe grad mal den TTimer ausprobiert und war entsetzt wie ungenau der ist
Da ich in schon früher in Delphi 6 das gleiche Problem hatte, habe ich eine MultiMedia Timer Komponente gebaut
und die funktioniert (leider nur in Windows
) wesentlich genauer. Hier kann man wirklich mit Einer Millisekunde arbeiten.Den Code stelle ich euch gern zur Verfügung, vielleicht kann man ja davon was gebrauchen...
Code: Alles auswählen
{ Siro, am 23.01.2017 fuer Lazarus Windows angepasst }
unit PrecTimer;
interface
uses
Windows, Classes, MMSystem;
CONST DefaultTimerResolution = 1; { minimale Auflösung des Timers 1 ms }
DefaultTimerIntervall = 1000; { Standard Intervallzeit 1 Sekunde }
{ neue Definition des Ereignisses OnTimer. }
{ Bei OnTimer wird ein Zeitwert "Time" übergeben. Hier wird die Zeit in }
{ Mili Sekunden nach dem Start bzw. letztem Reset des Timers übergeben. }
Type TOnTimer = procedure(Sender:TObject) of Object;
Type TPreciseTimer = class(TComponent)
private
FAutoStart : Boolean; { TRUE = Timer automatisch starten }
FInTimerProc : Boolean; { Anti Rekursions Flag }
FTimerRes : DWORD; { minimale Auflösung in milli Sekunden }
FTimerID : DWORD; { von Windows vergebene Timer Ident Nummer }
FInterval : DWord; { Aufrufintervall in milli Sekunden }
FRunning : Boolean; { TRUE = Timer lauft }
FOnTimer : TOnTimer; { Benutzer Routine "OnTimer" im Objectinspector }
protected
procedure SetInterval(NewInterval:DWORD);
procedure SetTimerRes(NewRes:DWORD);
procedure Loaded; override; { wird für AutoStart benötigt }
public
constructor create(AOwner: TComponent); override;
destructor destroy; override;
procedure Start; { Startet den Timer }
procedure Stop; { Stoppt den Timer }
procedure Reset; { setzt Timerzähler "Time" auf 0 }
published
property Interval : DWORD read FInterval write SetInterval;
property Resolution : DWORD read FTimerRes write SetTimerRes;
property OnTimer : TOnTimer read FOnTimer write FOnTimer;
property Running : Boolean read FRunning;
property AutoStart : Boolean read FAutoStart write FAutoStart;
end;
procedure Register;
implementation
{ ! ALLE Timer rufen diese Funktion auf. Anhand von "Sender" können die Timer }
{ auseinander gehalten werden. }
{ Diese Routine darf auf keinen Fall in das Object mit aufgenommen werden, }
{ sonst stimmen die Stackübergabe Parameter nicht mehr, da Delphi Komponenten }
{ immer einen unsichtbaren Parameter "Self" mit auf den Stack übergibt. }
{ Die sogenannte "Callback Funktion" von Windows weis davon aber nichts. }
{ Hat ewig gedauert bis der Fehler offensichtlich wurde. }
{ Hier wurde Sicherheitshalber ein Rekursionsflag mit eingebaut. }
{ Falls der letzte Aufruf noch nicht beendet wurde, wird der neue ignoriert, }
{ damit das System nicht hängen bleibt. }
procedure TimerProc(uID:UINT;msg:UINT; Sender,dw1,dw2:DWORD); stdcall;
begin
With TPreciseTimer(TObject(Sender)) do begin
if FInTimerProc then begin
Stop;
FInTimerProc:=FALSE;
exit; { der letzte Aufruf wurde noch nicht beendet }
end;
FInTimerProc:=TRUE; { der neue Aufruf ist in Arbeit }
if Assigned(OnTimer) then OnTimer(TObject(Sender)); { Benutzer Routine }
FInTimerProc:=FALSE; { der Aufruf wurde beendet }
end;
end;
constructor TPreciseTimer.create(AOwner: TComponent);
var TimeCaps:TTimeCaps;
begin
inherited create(AOwner);
FInterval := DefaultTimerIntervall;
FTimerRes := DefaultTimerResolution;
{ prüfen ob Windows diese Auflösung unterstütz. Wenn nicht wird }
{ die minimale Auflösung die Windows ermöglicht eingestellt. }
timeGetDevCaps(@TimeCaps,SizeOf(TTimeCaps));
if FTimerRes < TimeCaps.wPeriodMin then FTimerRes:=TimeCaps.wPeriodMin;
end;
destructor TPreciseTimer.destroy;
var t:DWORD;
begin
if FInTimerProc then begin
t:=GetTickCount64+3000;
repeat
until (GetTickCount64 > t) or (NOT FInTimerProc);
end;
Stop;
inherited destroy;
end;
procedure TPreciseTimer.Start; { Startet den Timer }
begin
if FRunning then exit; { Timer läuft schon }
timeBeginPeriod(FTimerRes);
FTimerId:=timeSetEvent(FInterval,FTimerRes,@TimerProc,DWORD(self),TIME_PERIODIC);
if FTimerId = 0 then begin { Windows konnte keinen Timer erzeugen }
timeEndPeriod(FTimerRes); { sofort timeEndPeriod aufrufen }
FRunning:=FALSE; { Timer läuft demnach nicht }
end else FRunning:=TRUE; { ansonsten läuft der Timer }
end;
procedure TPreciseTimer.Stop; { Stoppt den Timer }
begin
if NOT FRunning then exit; { wenn Timer schon gestoppt ist }
if FTimerId = 0 then exit; { es wurde kein Timer erzeugt }
timeKillEvent(FTimerId);
timeEndPeriod(FTimerRes);
FRunning:=FALSE; { Timer steht nun }
end;
procedure TPreciseTimer.Reset; { setzt den Zählerstand auf 0 }
begin
end;
{ setzt einen neuen Zeitintervall. Wenn der Timer schon läuft, }
{ wird er kurz ausgeschaltet, dann der neue Intervall gesetzt und }
{ wieder eingeschaltet }
procedure TPreciseTimer.SetInterval(NewInterval:DWORD);
var F:Boolean;
begin
if NewInterval = FInterval then exit; { steht schon auf dem Wert }
F:=FRunning; { merken ob Timer gerade läuft }
Stop; { auf jeden Fall den Timer stoppen }
FInterval:=NewInterval; { neune Intervall setzen }
if F then Start; { evtl. Timer wieder starten }
end;
procedure TPreciseTimer.SetTimerRes(NewRes:DWORD);
var F:Boolean; TimeCaps:TTimeCaps;
begin
if NewRes = FTimerRes then exit; { steht schon auf dem Wert }
F:=FRunning; { merken ob Timer gerade läuft }
Stop; { auf jeden Fall Timer stoppen }
FTimerRes:=NewRes; { Neue Auflösung setzen }
{ prüfen ob Windows diese Auflösung unterstützt. Wenn nicht wird }
{ die minimale Auflösung die Windows angibt benutzt. }
timeGetDevCaps(@TimeCaps,SizeOf(TTimeCaps));
if FTimerRes < TimeCaps.wPeriodMin then FTimerRes:=TimeCaps.wPeriodMin;
if F then Start; { evtl. Timer wieder Starten }
end;
{ nachdem alle Komponenten initialisiert und geladen wurden, wird automatisch }
{ für jede Kompoonente "Loaded" aufgerufen. Hier wird, wenn AutoStart auf TRUE }
{ steht der Timer gestartet. }
procedure TPreciseTimer.Loaded;
begin
if AutoStart then Start;
end;
procedure Register;
begin
RegisterComponents('SiroNeu', [TPreciseTimer]);
end;
end.
Verein
Links
Suche