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.