Pause in Timer setzen

[Baerlemann]

Hier eine nachbearbeitete Version zur Vermeidung "eingefrorener" Zustand,
mit dem ich in meiner Applikation zu kämpfen hatte.

Delphi-Quellcode:

// 2015-08-26 - Rev.2.0.6.1
// * !HOT BUGFIX! procedure TPauseTimer.Resume:
//   - Ursache für sporadisch "eingefrorener" Timer gefunden
//   - Finterval hat dann Wert $FFFFFFF<x> (In Eventlog Resume -> SetInterval)
//   - Daher zusätzlichen Check eingebaut ob FInterval > FMainInterval ist
//   - Bisheriger Check auf "0" geändert auf ResumeIntervalValue < 100
//     zur Vermeidung zu kleine Rest Intervallzeit bis nächsten Timer Event
//   - Kommt einer dieser beiden Fälle vor, wird FInterval zurückgesetzt
//     auf FMainInterval Wert
//---------------------------------------------------------------------------------------------------------
// 2015-08-21 - Rev.2.0.5.1
// * !WICHTIGER BUGFIX! procedure TPauseTimer.Resume:
//   - Check eingebaut of ResumeIntervalValue den Wert 0 erhält
//     ResumeIntervalValue := FInterval - (FPauseTime-FStartTime);
//     Bei "Value = 0" muss hier "Value <> 0" eingestellt werden
//     Es wird "Value := 50" eingestellt = 50msec bis nächster TimerEvent
//     Bei "Value = 0" wird der Timer NICHT mehr neu gestartet !!!
//     (Siehe "SetInterval -> UpdateTimer")
//     --> Timersteuerung bleibt dann stehen !!
//     !NACHTRAG! Das ist nicht der Grund für "eingefrorenen" Timer
//     (siehe HOT Bugfix 2015-08-26)
//---------------------------------------------------------------------------------------------------------
// 2015-08-05 - Rev.2.0.1.1
// !NEU! Dieser Timer wird ab sofort als ZENTRALER "RatePBPauseTimer" genutzt !
// TimerKomponente die mit PAUSE/RESUME angehalten werden kann
// läuft dann weiter mit dem zwischengespeicherten Wert
// Vorlage kopiert von:
// "http://www.delphipraxis.net/44768-pause-timer-setzen.html"
//========================================================================================================
unit PauseTimer;

interface

uses
  SysUtils, Classes, Windows, Forms, ExtCtrls, Messages;

type
  TPauseTimer = class(TComponent)
  private
    m_CalledFromWhere : string;
    m_CalledFromMain  : string;
    FInterval,
    FMainInterval,
    FStartTime,
    FPauseTime: Cardinal;
    FWindowHandle: HWND;
    FOnTimer: TNotifyEvent;
    FEnabled: Boolean;
    procedure UpdateTimer;
    procedure SetEnabled(Value: Boolean);
    procedure SetMainInterval(Value: Cardinal);
    procedure SetInterval(Value: Cardinal);
    procedure SetOnTimer(Value: TNotifyEvent);
    procedure WndProc(var Msg: TMessage);
  protected
    procedure Timer; dynamic;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  published
    property Delay: Cardinal read FInterval;
    property Enabled: Boolean read FEnabled write SetEnabled default True;
    property Interval: Cardinal read FMainInterval write SetMainInterval default 1000;
    property OnTimer: TNotifyEvent read FOnTimer write SetOnTimer;
    procedure Pause;
    Procedure Resume;
  end;

//procedure Register;

implementation


constructor TPauseTimer.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FEnabled := True;
  FMainInterval := 1000;
  FInterval := 1000;
  FPauseTime := 0;
  FStartTime := 0;
  FWindowHandle := Classes.AllocateHWnd(WndProc);
end;

destructor TPauseTimer.Destroy;
begin
  m_CalledFromWhere := 'Destroy';
  FEnabled := False;
  UpdateTimer;
  Classes.DeallocateHWnd(FWindowHandle);
  inherited Destroy;
end;

procedure TPauseTimer.WndProc(var Msg: TMessage);
begin
  with Msg do
  begin
    if Msg = WM_TIMER then
    begin
      try
        Timer;
      except
        Application.HandleException(Self);
      end;
    end else
    begin
      Result := DefWindowProc(FWindowHandle, Msg, wParam, lParam);
    end;
  end; //with Msg
end;

procedure TPauseTimer.UpdateTimer;
const FunctionName = 'TPauseTimer.UpdateTimer';
begin
  KillTimer(FWindowHandle, 1);
  if (FInterval <> 0) and FEnabled and Assigned(FOnTimer) then
  begin
    if SetTimer(FWindowHandle, 1, FInterval, nil) = 0 then
    begin
      raise EOutOfResources.Create('Timer Error');
    end;
    FStartTime:=GetTickCount;
  end;
end;

procedure TPauseTimer.SetEnabled(Value: Boolean);
begin
  m_CalledFromWhere := m_CalledFromMain + ' -> SetEnabled';
  if Value <> FEnabled then
  begin
    FEnabled := Value;
    UpdateTimer;
  end;
end;

procedure TPauseTimer.SetInterval(Value: Cardinal);
begin
  m_CalledFromWhere := m_CalledFromMain + ' -> SetInterval';
  if Value <> FInterval then
  begin
    FInterval := Value;
    UpdateTimer;
  end;
end;

procedure TPauseTimer.SetMainInterval(Value: Cardinal);
begin
  FMainInterval := Value;
  FPauseTime := 0;
  m_CalledFromMain := 'SetMainInterval';
  SetInterval(Value);
  m_CalledFromMain := 'N/A';
end;

procedure TPauseTimer.SetOnTimer(Value: TNotifyEvent);
begin
  m_CalledFromWhere := 'SetOnTimer';
  FOnTimer := Value;
  UpdateTimer;
end;

procedure TPauseTimer.Timer;
begin
  m_CalledFromWhere := 'Timer';
  if Assigned(FOnTimer) then
  begin
    FInterval:=FMainInterval;
    FOnTimer(Self);
    UpdateTimer;
  end;
end;

procedure TPauseTimer.Pause;
begin
  if not FEnabled then Exit;
  FPauseTime:=GetTickCount;
  m_CalledFromMain := 'Pause';
  SetEnabled(False);
  m_CalledFromMain := 'N/A';
end;

procedure TPauseTimer.Resume;
const FunctionName = 'TPauseTimer.Resume';
var ResumeIntervalValue : Cardinal;
begin
  if FEnabled then Exit;
  if FPauseTime <> 0 then
  begin
    ResumeIntervalValue := FInterval - (FPauseTime-FStartTime);
    //******************************************************************************
    // !BUGFIX! Bei "Value = 0" muss "Value <> 0" eingestellt werden
    // Sonst wird in "SetInterval -> UpdateTimer" der Timer NICHT mehr gestartet !!!
    // RTHA 2015-08-25 - Check geändert "Value = 0" ==> "Value < 100"
    // Vermeidung zu kleine Rest Intervallzeit bis nächsten Timer Event
    // ResumeIntervalValue := 100 --> 100 msec bis nächsten Timer Event
    //******************************************************************************
    // !BUGFIX! 2. Ursache für "eingefrorenen" Timer gefunden
    // ResumeIntervalValue wird sporadisch mit Wert $ FFFF FFF<x> (Hex) belegt ??!!
    // Timer wird zwar wieder gestartet jedoch mit dieser extrem langen Laufzeit
    // Damit Eindruck eingefrorener Zustand !!!
    // Typ Cardinal = 32 Bit OHNE Vorzeichen !
    // Check eingebaut of ResumeIntervalValue > FMainInterval geworden ist
    // --> Dann ResumeIntervalValue auf FMainInterval setzen
    //******************************************************************************
    if (ResumeIntervalValue < 100) or
       (ResumeIntervalValue > FMainInterval) then
    begin
      ResumeIntervalValue := FMainInterval; // !! RESET auf FMainInterval Wert !!
    end;
    m_CalledFromMain := 'Resume';
    SetInterval(ResumeIntervalValue); // FEnabled ist hier noch "FALSE" bei vorheriger PAUSE
    m_CalledFromMain := 'N/A';
    FPauseTime:=0;
  end;
  m_CalledFromMain := 'Resume';
  SetEnabled(True);
  m_CalledFromMain := 'N/A';
end;

//procedure Register;
//begin
//  RegisterComponents('User Tools', [TPauseTimer]);
//end;

end.

[Monday]

Hätte man nicht auch mit einem zweiten Timer arbeiten können? Wenn der erste Pausieren soll, dann wird Timer1 deaktiviert, Timer2 (Pausentimer) aktiviert und nach abgelaufender Zeit deaktiviert sich Timer2 selbst und aktiviert Timer 1 wieder. ?

[Blup]

UpdateTimer sollte vor FOnTimer() aufgerufen werden, sonst verfälschen lange Laufzeiten der OnTimer-Methode die Genauigkeit.

Delphi-Quellcode:

    UpdateTimer;
    FOnTimer(Self);

Da Windows-PCs manchmal auch über mehrere Tage laufen, besser mit GetTickCount64() arbeiten.
http://www.delphipraxis.net/711170-post5.html

[Glados]

Von welcher Beschränkung genau sprichst du?

Meinst du, dass man Dax's GetTickCount64-Code auch unter XP verwenden kann? Kann man Winapi.Windows.GetTickCount64 nicht unter XP verwenden?

[himitsu]

Bezogen auf den Windows-Timer (SetTimer, KillTimer und WM_TIMER)
gibt es leider keinen API-Aufruf für "Pause"
und es ist auch nicht möglich abzufragen wann das letzte oder nächste Event war/kommt. (hier könnte man sich sonst die Restzeit merken und sie für den nächsten Start verwenden)

Man könnte sowas aber in TTimer (VCL) einbauen, also das letzte Event speichern (z.B. GetTickCount) und das für einen Pause/Restore-Befehl zu nutzen.
FMX-Timer weiß ich nicht wie der arbeitet, in jedem möglichen OS, und ob es da nicht bessere/direktere Möglichkeiten gibt.