以前、少し違う方法でこの質問をしました。その瞬間、フォーラムから得た回答を試し始めるまで、問題が正確に何であるかがわかりませんでした（すべてに感謝します）。問題はこれです：
MIDI を生成するには、良いタイマーが必要です。私は今4つ持っていますが、それらはすべて簡単なヒントで中断されます. アプリケーションを起動したり、重い計算を実行したりできます。タイマーは汗をかかずに機能します。ヒントが 1 つあると、可聴遅延が発生します。4 つのタイマーすべてを試しましたが、基本的に同じ動作を示します。それらのいくつかは、最も優先度の高いスレッドで実行されます。
1 つのタイマーのコードは次のようになります。他にも追加できますが、それは私が考えるポイントではありません。Delphi または Windows には、Timecritical スレッドよりも優先度の高い固有のものがあるようです。
ユニット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* 設定がいくつかありましたが、これへのすべての参照を削除しました。これは違いはありませんでした。
私が間違っていることを誰か知っていますか？