Multimedia Timer

[hanspeter]

Also um das Thema abzuschließen.
timeSetEvent funktioniert unter XE2 und W8 nicht.
Nach ca. 1500 Zyklen tritt ein Stack-Überlauf auf.
timeSetEvent wollte ich nutzen um einen Takt für eine Steuerung 1ms/10ms/100ms zu erzeugen.
Mit 2 Opensource Highres Timern trat das gleiche Problem auf.
Irgendwo hier im Forum wird erwähnt das timeSetEvent veraltert ist und besser CreateTimerQueueTimer verwendet wird.
Ich habe das Problem jetzt mit CreateTimerQueueTimer gelöst.
Jetzt funktioniert es in der gewünschten Form.
Für Interessenten, in der Anlage mal die komplette Lösung.

Gruß
Peter

Delphi-Quellcode:

unit UpProcess;
interface
uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants,
  System.Classes, System.SyncObjs, engbaslib, MMSystem, Vcl.StdStyleActnCtrls;

  type
    pCallback =  procedure of Object;

type
  TProcessRun = class(TThread)
  private
    aPause : integer;
    FCS    : TCriticalSection;
  protected
    procedure Execute; override;
  public
    run1ms       : boolean;
    TimeTakt     : int64;
    TimeTakt10   : integer;
    TimeTakt100  : integer;
    TimeTakt1000 : integer;
    Pause        : integer;
    Callback1ms   : pCallback;
    Callback10ms  : pCallback;
    Callback100ms : pCallback;
    Callback1000ms: pCallback;
    Constructor Create;overload;
    destructor Destroy; override;
    procedure Stopp;
  end;

Var
  FTimer: THandle;
  run:   TProcessRun;

implementation

procedure WaitOrTimer(Context: Pointer; Success: Boolean) stdcall;
begin
  inc(run.TimeTakt10);
  inc(run.TimeTakt100);
  inc(run.TimeTakt1000);
  run.run1ms := true;
end;

Constructor TProcessRun.Create;
begin
  Self.Create(true);
  FreeOnTerminate:=true;
  Priority:= tpHighest;
  TimeTakt     := 0;
  TimeTakt10   := 0;
  TimeTakt100  := 0;
  TimeTakt1000 := 0;
  Pause        := 0;
  FCS := TCriticalSection.Create;
  if not CreateTimerQueueTimer(FTimer, 0, WaitOrTimer, 0, 0, 1,
    WT_EXECUTEINTIMERTHREAD) then
    FTimer := 0;
end;

destructor TProcessRun.Destroy;
begin
  Stopp;
  freeandnil(FCS);
  inherited;
end;

procedure TProcessRun.Stopp;
begin
  if FTimer <> 0 then
   begin
     DeleteTimerQueueTimer(0, FTimer, 1);
     FTimer := 0;
   end;
end;

{ TProcessRun }

procedure TProcessRun.Execute;
begin
  NameThreadForDebugging('Processrun');
  while not Terminated do
  begin
    inc(aPause);
    if run1ms then
    begin
      run1ms := false;
      Pause  := aPause;
      aPause := 0;
      // FCS.Enter;

      if Assigned(Callback1ms) then
      begin
        Synchronize(Callback1ms);
      end;

      if TimeTakt10 >= 10 then
      begin
        TimeTakt10 := 0;
        if Assigned(Callback10ms) then Synchronize(Callback10ms);
      end;

      if TimeTakt100 >= 100 then
      begin
        TimeTakt100 := 0;
        if Assigned(Callback100ms) then Synchronize(Callback100ms);
      end;

      if TimeTakt1000 >= 1000 then
      begin
        TimeTakt1000 := 0;
        if Assigned(Callback1000ms) then Synchronize(Callback1000ms);
      end;
  //    FCS.Leave;
    end;
  end;
end;

end