Команды Pause и Delay вместо Sleep

unit uPlayers;
 
interface
 
uses
  //============================== Модули проекта ==============================
  uInpOut, uResources,
  //========================= Модули проекта с формами =========================
  //=============================== Левые модули ===============================
  //=================== Системные модули, добавленные вручную ==================
  Windows, Classes, MMSystem;
 
type
  // --------------------- Класс - высокоточный таймер -------------------------
  THRTimer = class(TObject)
    constructor Create;
    function StartTimer: Boolean; // Обнуление таймера
    function ReadTimer: Double;   // Чтение значения таймера в миллисекундах
  private
    StartTime: Double;
    ClockRate: Double;
  public
    Exists: Boolean;    // Флаг успешного создания таймера
  end;
 
  TMyThread = class(TThread)
  private
    FID: Pointer;
    FLooped: Boolean;
    FTimer: THRTimer;
    FProgress: Integer; // 0...100%
 
    FOnBeforeStart: TNotifyEvent;
    FOnProgress: TNotifyEvent;
    procedure SetInteger(const ANew: Integer);
    function GetInteger: Integer;
  protected
    procedure DoProgress; dynamic;
    //property Looped: Boolean read FLooped write FLooped;
  public
    constructor Create; dynamic;
    destructor Destroy; override;
    procedure Start; dynamic;
    property ID: Pointer read FID write FID;
    property ID_as_Integer: Integer read GetInteger write SetInteger;
    property Progress: Integer read FProgress;
    property Looped: Boolean read FLooped write FLooped;
    property OnBeforeStart: TNotifyEvent read FOnBeforeStart write FOnBeforeStart;
    property OnProgress: TNotifyEvent read FOnProgress write FOnProgress;
  end;
 
type
  // Класс - роигрыватель звуков через спикер
  TPCSpeakerPlayer = class(TMyThread)
  private
    FPort: TPCSpeakerPort;
 
    FFrequency: Word;
    FDuration: DWORD;
    FSample: PDWord; // проигрывается, если <> nil и размер <> 0
    FSampleSize: DWORD; // длина сэмпла
    FSampleIndex: DWORD;
 
    FOnBeforeSampleItem: TNotifyEvent;
  protected
    procedure DoBeforeSampleItem;
    procedure Execute; override;
    procedure DoTerminate; override;
  public
    constructor Create; override;
    destructor Destroy; override;
    property Frequency: Word read FFrequency write FFrequency;
    property Duration: DWORD read FDuration write FDuration;
    property Sample: PDWORD read FSample write FSample;
    property SampleSize: DWORD read FSampleSize write FSampleSize;
    property SampleIndex: DWORD read FSampleIndex;
 
    property OnBeforeSampleItem: TNotifyEvent read FOnBeforeSampleItem write FOnBeforeSampleItem;
  end;
 
  // Класс - проигрыватель звуков (абстрактный предок)
  TMyPlayer = class abstract(TMyThread)
  private
    FDuration: DWORD;
  protected
    procedure Execute; override;
    procedure Play; dynamic; abstract;
    procedure Stop;
    property Duration: DWORD read FDuration write FDuration;
  public
    destructor Destroy; override;
  end;
 
  // Класс - роигрыватель звуков из ресурсов
  TWaveResourcePlayer = class(TMyPlayer)
  private
    FResourceName: string;
  protected
    procedure Play; override;
  public
    constructor Create(const AResourceName: string; const ADuration: DWORD); reintroduce;
    property ResourceName: string read FResourceName write FResourceName;
    property Duration;
  end;
 
  // Класс - роигрыватель звуков из памяти
  // именно этот класс проигрывает звук из файла и из ресурса в боевом режиме.
  // TWaveResourcePlayer - только для прослушивания в окне настроек
  // (нахрена я так сделал? убрать?)
  TWaveMemoryPlayer = class(TMyPlayer)
  private
    FMemoryPtr: Pointer;
  protected
    procedure Play; override;
  public
    constructor Create(const AMemoryPtr: Pointer; const ADuration: DWORD); reintroduce;
    property Duration;
    property Looped;
  end;
 
const
  ID_WAVERESOURCE_PLAYER     = 1;
  ID_WAVEMEMORY_PLAYER       = ID_WAVERESOURCE_PLAYER + 1;
  ID_PCSPEAKER_PLAYER        = ID_WAVEMEMORY_PLAYER + 1;
 
var
  StreamSoundData: TMediaStream;
 
implementation
 
{$REGION 'THRTimer'}
 
constructor THRTimer.Create;
var
  QW: LARGE_INTEGER;
begin
  inherited Create;
  Exists := QueryPerformanceFrequency(Int64(QW));
  ClockRate := QW.QuadPart;
end;
 
function THRTimer.StartTimer: Boolean;
var
  QW: LARGE_INTEGER;
begin
  Result := QueryPerformanceCounter(Int64(QW));
  StartTime := QW.QuadPart;
end;
 
function THRTimer.ReadTimer: Double;
var
  ET: LARGE_INTEGER;
begin
  QueryPerformanceCounter(Int64(ET));
  Result := 1000.0 * (ET.QuadPart - StartTime) / ClockRate;
end;
 
{$ENDREGION}
 
{$REGION 'TMyThread'}
{ TMyThread }
 
constructor TMyThread.Create;
begin
  inherited Create(true);
  FTimer:= THRTimer.Create();
end;
 
destructor TMyThread.Destroy;
begin
  FTimer.Free();
  inherited;
end;
 
procedure TMyThread.DoProgress;
begin
  if Assigned(FOnProgress)
    then FOnProgress(Self);
end;
 
function TMyThread.GetInteger: Integer;
begin
  Result:= Integer(FID);
end;
 
procedure TMyThread.SetInteger(const ANew: Integer);
begin
  FID:= Pointer(ANew);
end;
 
procedure TMyThread.Start;
begin
  if Assigned(FOnBeforeStart)
    then FOnBeforeStart(Self);
 
  FreeOnTerminate:= True; // ВСЕГДА!!!
  inherited Start();
end;
 
{$ENDREGION}
 
{$REGION 'TPCSpeakerPlayer'}
 
constructor TPCSpeakerPlayer.Create;
begin
  inherited Create();
  FPort:= TPCSpeakerPort.Create();
  FFrequency:= 880;
  FDuration:= 500;
  FID:= Pointer(ID_PCSPEAKER_PLAYER); // по умолчанию
end;
 
destructor TPCSpeakerPlayer.Destroy;
begin
  FPort.Free();
 
  inherited;
end;
 
procedure TPCSpeakerPlayer.DoBeforeSampleItem;
begin
  if Assigned(FOnBeforeSampleItem)
    then FOnBeforeSampleItem(Self);
end;
 
procedure TPCSpeakerPlayer.DoTerminate;
begin
  Self.FPort.NoSound();
  inherited;
end;
 
procedure TPCSpeakerPlayer.Execute;
var
  ptr: PDWORD;
  CurTime: Double;
  old: Integer;
begin
  old:= 0;
  FProgress:= 0;
 
  if Assigned(FSample) and (FSampleSize <> 0)
    then begin
           FSampleIndex:= 0;
           ptr:= FSample;
           repeat
             FFrequency:= ptr^ and $0000FFFF;
             FDuration:=  ptr^ shr 16;
             Synchronize(DoBeforeSampleItem);
             FTimer.StartTimer();
             FPort.Sound(FFrequency);
 
             repeat
               Self.Yield();
               // хоть этот кусок в проекте не используется, сделать вызов
               // OnProgress и отсюда.
             until Terminated or (FTimer.ReadTimer() > FDuration);
 
             FPort.NoSound();
             Inc(FSampleIndex);
             Inc(FSample);
           until Terminated or (FSampleIndex = FSampleSize);
         end
    else begin // единичный звук
           FTimer.StartTimer();
           FPort.Sound(FFrequency);
 
           repeat
             Self.Yield();
             FPort.Sound(FFrequency); // смена частоты на лету
 
             // прогресс
             CurTime:= FTimer.ReadTimer();
 
             if not Looped
               then begin
                      FProgress:= Round(100 * CurTime / FDuration);
 
                      if FProgress <> old
                        then begin
                               old:= FProgress;
                               Synchronize(DoProgress);
                             end;
                    end;
           until Terminated or ((not FLooped) and (CurTime > FDuration));
 
           FPort.NoSound();
         end;
end;
 
{$ENDREGION}
 
{$REGION 'TMyPlayer'}
{ TMyPlayer }
 
destructor TMyPlayer.Destroy;
begin
  Stop();
  inherited;
end;
 
procedure TMyPlayer.Execute;
var
  CurTime: Double;
  old: Integer;
begin
  old:= 0;
  FProgress:= 0;
 
  Play();
  try
    // цикл треда
    FTimer.StartTimer();
    repeat
      Sleep(10);
 
       // прогресс
       CurTime:= FTimer.ReadTimer();
 
       FProgress:= Round(100 * CurTime / FDuration); // здесь FDuration не может быть = 0 (читается из ресурса или из стрима)
 
       if FProgress <> old
         then begin
                old:= FProgress;
                Synchronize(DoProgress);
              end;
    until Terminated or (FTimer.ReadTimer() > FDuration);
  finally
    Stop();
  end;
end;
 
procedure TMyPlayer.Stop;
begin
  PlaySound(nil, 0, 0);
end;
 
{$ENDREGION}
 
{$REGION 'TWaveResourcePlayer'}
{ TWaveResourcePlayer }
 
constructor TWaveResourcePlayer.Create(const AResourceName: string;
  const ADuration: DWORD);
begin
  inherited Create();
  FID:= Pointer(ID_WAVERESOURCE_PLAYER); // по умолчанию
  FResourceName:= AResourceName;
 
  if ADuration <> 0
    then FDuration:= ADuration
    else FDuration:= GetWaveResourceDuration(FResourceName); // если не длительность задана - читаю из ресурса
end;
 
procedure TWaveResourcePlayer.Play;
begin
  inherited;
  PlaySound(PChar(FResourceName), hInstance, SND_RESOURCE or SND_ASYNC);
end;
 
{$ENDREGION}
 
{ TWaveMemoryPlayer }
 
constructor TWaveMemoryPlayer.Create(const AMemoryPtr: Pointer;
  const ADuration: DWORD);
begin
  inherited Create();
  FID:= Pointer(ID_WAVEMEMORY_PLAYER); // по умолчанию
  FMemoryPtr:= AMemoryPtr;
  FDuration:= ADuration;
end;
 
procedure TWaveMemoryPlayer.Play;
var
  fdwSound: DWORD;
begin
  inherited;
  if FLooped
    then fdwSound:= SND_MEMORY or SND_ASYNC or SND_LOOP
    else fdwSound:= SND_MEMORY or SND_ASYNC;
  PlaySound(FMemoryPtr, hInstance, fdwSound);
end;
 
initialization
  // данные для проигрывания сигналов через звуковую карту
  StreamSoundData:= TMediaStream.Create();
 
finalization
  StreamSoundData.Clear();
  StreamSoundData.Free();
 
end.