如何防止提示中断计时器

Question

我之前问过这个问题，方式略有不同。那时我不知道问题到底是什么，直到我开始尝试从论坛得到的答案（谢谢大家）。问题是这样的：

对于 MIDI 生成，我需要一个好的计时器。我现在有四个，但它们都被一个简单的提示打断了。我可以启动应用程序、执行繁重的计算等等。计时器运行起来毫不费力。一个提示会产生声音延迟。我尝试了所有4个计时器并且他们基本上表现出相同的行为。其中一些在具有最高优先级的线程中运行。

一个计时器的代码如下所示。我可以添加其他内容，但这不是我认为的重点。看来 Delphi 或 Windows 中有一些固有的东西比时间关键线程具有更高的优先级。

单位Timer_Looping；

  interface

  uses Windows, MMSystem, Messages, SysUtils, Classes, Graphics, Controls, Forms,
       Dialogs, Timer_Custom;

  type
     TTask = class (TThread)
     private
        FEnabled: boolean;
        FInterval: cardinal;
        FOnTimer: TNotifyEvent;

        procedure Yield;

     public
        constructor Create;
        destructor Destroy; override;
        procedure Execute; override;

        property Enabled: boolean read FEnabled write FEnabled;
        property Interval: cardinal read FInterval write FInterval;
        property OnTimer: TNotifyEvent read FOnTimer write FOnTimer;
     end; // Class: TWork //

     TLoopingTimer = class (TBaseTimer)
     protected
        FTask: TTask;

        procedure SetEnabled (value: boolean); override;
        procedure SetInterval (value: cardinal); override;
        procedure SetOnTimer (Task: TNotifyEvent); override;

        procedure StartTimer;
        procedure StopTimer;

     public
        constructor Create;
        destructor Destroy; override;
     end; // Class: TLooping_Timer //

  implementation

  {*******************************************************************
  *                                                                  *
  * Class TTask                                                      *
  *                                                                  *
  ********************************************************************}

  constructor TTask.Create;
  begin
     inherited Create (False);

     Self.Priority := tpTimeCritical;
  end; // Create //

  {$WARN SYMBOL_DEPRECATED OFF}
  destructor TTask.Destroy;
  begin
     Terminate;                 // terminate execute loop
     if Suspended then Resume;  // Resume the Task when waiting
     WaitFor;                   // Wait until the thread is terminated
  end; // Destroy //

  // Return control to another thread, ProcessMessages without the disadvantages
  procedure TTask.Yield;
  begin
     if Win32MajorVersion >= 6  // Vista, 2008, 7?
        then asm pause; end     // Most efficient
        else SwitchToThread;    // Else: don't use ProcessMessages or Sleep(0)
  end; // yield //

  // Execute loop, calls the callback and suspends. The timer callback
  // resumes the timer
  procedure TTask.Execute;
  var freq, time, limit: Int64;
      ms_interval: Int64;       // Interval in cycles
  begin
     QueryPerformanceFrequency (freq);
     try
        Suspend;

  // Just loop until Terminate is set
        while not Terminated do
        begin
           ms_interval := Interval * freq div 1000;

  // Loop between Enabled and Disabled
           while not Terminated and Enabled do
           begin
              QueryPerformanceCounter (time);
              limit := time + ms_interval;
              if Assigned (OnTimer) then OnTimer (Self);

  // Wait by cycling idly thru cycles. QueryPerformanceCounter is used for precision.
  // When using GetTickCount deviations of over 10ms may occur.
              while time < limit do
              begin
                 yield;
                 QueryPerformanceCounter (time);
              end; // while
           end; // while
           if not Terminated then Suspend;
        end; // while
     except
        Terminate;
     end; // try
  end; // Execute //

  {$WARN SYMBOL_DEPRECATED ON}

  {*******************************************************************
  *                                                                  *
  * Class TLooping_Timer                                             *
  *                                                                  *
  ********************************************************************}

  constructor TLoopingTimer.Create;
  begin
     inherited Create;

     FTask := TTask.Create;
     FTimerName := 'Looping';
  end; // Create //

  // Stop the timer and exit the Execute loop
  Destructor TLoopingTimer.Destroy;
  begin
     Enabled := False;          // stop timer when running
     FTask.Free;

     inherited Destroy;
  end; // Destroy //

  {$WARN SYMBOL_DEPRECATED OFF}
  procedure TLoopingTimer.StartTimer;
  begin
     FTask.Enabled := True;
     FTask.Resume;
  end; // StartBeat //
  {$WARN SYMBOL_DEPRECATED ON}

  procedure TLoopingTimer.StopTimer;
  begin
     FTask.FEnabled := False;
  end; // PauseBeat //

  procedure TLoopingTimer.SetOnTimer (Task: TNotifyEvent);
  begin
     inherited SetOnTimer (Task);

     FTask.OnTimer := Task;
  end; // SetOnTimer //

  // When true, startbeat is called, else stopbeat
  procedure TLoopingTimer.SetEnabled (value: boolean);
  begin
     FEnabled := value;
     if FEnabled
        then StartTimer
        else StopTimer;
  end; // set_enabled //

  procedure TLoopingTimer.SetInterval (value: cardinal);
  begin
     FInterval := value;
     FTask.Interval := Interval;
  end; // SetInterval //

  end. // Unit: MSC_Threaded_Timer //      
  =====================Base class=========================

  unit Timer_Custom;

  interface

  uses
    Windows, MMSystem, Messages, SysUtils, Classes, Graphics, Controls, Forms,
    Dialogs;

  type
    TCallBack = procedure (uTimerID, uMessage: UINT; dwUser, dw1, dw2: DWORD);

    ETimer = class (Exception);

  {$M+}
     TBaseTimer = class (TObject)
     protected
        FTimerName: string;     // Name of the timer
        FEnabled: boolean;      // True= timer is running, False = not
        FInterval: Cardinal;      // Interval of timer in ms
        FResolution: Cardinal;    // Resolution of timer in ms
        FOnTimer: TNotifyEvent; // What to do when the hour (ms) strikes

        procedure SetEnabled (value: boolean); virtual;
        procedure SetInterval (value: Cardinal); virtual;
        procedure SetResolution (value: Cardinal); virtual;
        procedure SetOnTimer (Task: TNotifyEvent); virtual;

     public
        constructor Create; overload;

     published
        property TimerName: string read FTimerName;
        property Enabled: boolean read FEnabled write SetEnabled;
        property Interval: Cardinal read FInterval write SetInterval;
        property Resolution: Cardinal read FResolution write SetResolution;
        property OnTimer: TNotifyEvent read FOnTimer write SetOnTimer;
     end; // Class: HiResTimer //

  implementation

  constructor TBaseTimer.Create;
  begin
     inherited Create;

     FEnabled    := False;
     FInterval   := 500;
     Fresolution := 10;
  end; // Create //

  procedure TBaseTimer.SetEnabled (value: boolean);
  begin
     FEnabled := value;
  end; // SetEnabled //

  procedure TBaseTimer.SetInterval (value: Cardinal);
  begin
     FInterval := value;
  end; // SetInterval //

  procedure TBaseTimer.SetResolution (value: Cardinal);
  begin
     FResolution := value;
  end; // SetResolution //

  procedure TBaseTimer.SetOnTimer (Task: TNotifyEvent);
  begin
     FOnTimer := Task;
  end; // SetOnTimer //

  end. // Unit: MSC_Timer_Custom //

我无法在新程序中重复此行为。它在我的 MIDI 播放器中非常清晰地存在，该播放器太大，无法在此列出。我确实有一些 Application.Hint* 设置，但我已删除对此的所有引用。这没有什么区别。

有人知道我做错了什么吗？

Answer 1

您正在从后台线程调用 Application.ProcessMessages。不要那样做！

1. 当您执行此操作时，您将导致 Windows 消息在非主线程中处理。 VCL 不希望出现这种情况，这可能会导致各种问题。
2. 通过调用 ProcessMessages，您将引入未知长度的延迟。您不知道 ProcessMessages 需要多长时间才能返回。
3. 无需在后台线程中处理消息。如果你无事可做，请调用Sleep(0)或SwitchToThread。

回复3：你可以使用这样的东西：

procedure Yield;
begin
  if Win32Platform = VER_PLATFORM_WIN32_NT then
    asm pause; end
  else
    Sleep(0);
end;