Еще один "Windows.Beep"

[JekaDefer]

Народ делаю универсальный "Beep" помогите сделать так чтобы эта процедура использовав несколько буферов проигрывала сигнал больше чем 1 сек?

procedure WBeep(Freq, Time, Vol: Integer; SignalForm: Byte);
const
  sps	= 44100;	// samples per second (Hz)
var
  Frq_Base, Time_memo, Time_now, dif: Int64;

  nSamples: Integer;
  angle, delta: double;

  i: integer;

  Sample: array[0..sps] of integer;	// full second
  wout: hWaveOut;
  wfx : TWAVEFORMATEX;
  hdr: WAVEHDR;
  hEvent : THandle;
Begin
  //------------------Заполнение сэмплов
  nSamples := sps * time div 1000;	// Длинна сигнала в сэмплах
  angle := 0;
  Case SignalForm of
  0:  Begin  // Sinus
        delta := (freq / sps * 2) * 2 * Pi;	// how much in one sample
        for i := 0 to nSamples - 1 do
        begin
          Sample[i] := round(sin(angle) * Vol);
          angle := angle + delta;
        end;
      End;
  1:  Begin // Меандр
        delta := (freq / sps * 2) * 2 * Pi;	// how much in one sample
        for i := 0 to nSamples - 1 do
        begin
          if round(sin(angle) * Vol) > 0 then Sample[i] := Vol else Sample[i] := -Vol;
          angle := angle + delta;
        end;
      End;
  End;
  //-----------------ТТХ TWAVEFORMATEX
  With wfx do
  Begin
    wFormatTag := WAVE_FORMAT_PCM;                    // используется PCM формат
    nChannels := 1;                                   // Моно
    nSamplesPerSec := sps;                            // частота дискретизации
    wBitsPerSample := 16;                             // выборка 16 бит
    nBlockAlign := wBitsPerSample div 8 * nChannels;  // число байт в выбоке
    nAvgBytesPerSec := nSamplesPerSec * nBlockAlign;  // число байт в секундном интервале
    cbSize := 0;     // не используется
  End;
  //------------------Открытие устройства
  hEvent := CreateEvent(nil,false,false,nil);
  if WaveOutOpen(@wout,0,@wfx,hEvent,0,CALLBACK_EVENT) <> MMSYSERR_NOERROR then
  begin
    CloseHandle(hEvent);
    Exit;
  end;
  //-------------------Заполнение буфера
  fillChar(hdr, sizeof(hdr), #0);
  hdr.lpData := @Sample;
  hdr.dwBufferLength := sizeof(Sample);
  //-------------------Проигрывание
  waveOutPrepareHeader(wout, @hdr, sizeof(TWAVEHDR));
  WaveOutWrite(wout, @hdr, sizeof(hdr));
  WaitForSingleObject(hEvent, INFINITE);
  //-------------------Пауза на время проигрывания (Иначе не успеет проиграть)
  if QueryPerformanceFrequency(Frq_Base) then // Частота ПК
  begin
    QueryPerformanceCounter(Time_memo); // начальное значение
    repeat
      QueryPerformanceCounter(Time_now);
      dif := ((Time_now - Time_memo) * 1000000) div Frq_Base;
    until dif > Time*1000;//-47700; // Если нужно то учет погрешности
  end;
  //--------------------Освобождение памяти и закрытие устройства
  waveOutReset(wout);
  waveOutUnprepareHeader(wout, @hdr, sizeof(TWAVEHDR));
  VirtualFree(@Sample,0,MEM_RELEASE);
  WaveOutClose(wout);
  CloseHandle(hEvent);
End;

[veniside]

program
  GenWave;

{$APPTYPE CONSOLE }

uses
  Windows,
  SysUtils, Math, MMSystem;

type
  int 	= integer;
  int16 = smallint;
  bool	= LongBool;

const
  sps	= 44100;
  c_max_buffers	= 3;
  c_buf_size	= sps div 10;	// (100 ms)

var
  freq: int		= 4000;
  timeSignal: int	= 30;
  timePause: int	= 970;

var
  done: bool;
  buffer: array[0..c_max_buffers - 1, 0..c_buf_size - 1] of int16;
  event: tHandle;
  hdr: array[0..c_max_buffers - 1] of WAVEHDR;
  wout: hWaveOut = 0;
  //
  angle, delta: double;
  nSamples: int;
  isSignal: bool = false;

// --  --
procedure prepareSine(index: int);
var
  i: int;
begin
  i := 0;
  repeat
    //
    while ((0 < nSamples) and (i < c_buf_size)) do begin
      //
      if (isSignal) then begin
	//
	buffer[index][i] := round(sin(angle) * 32767);
	angle := angle + delta;
      end
      else
	buffer[index][i] := 0;
      //
      inc(i);
      dec(nSamples);
    end;
    //
    if (0 < nSamples) then
      break;
    //
    isSignal := not isSignal;
    if (isSignal) then begin
      //
      // stat new sine
      angle := 0;
      delta := (freq / sps) * 2 * Pi;
    end;
    //
    if (isSignal) then
      nSamples := sps * timeSignal div 1000
    else
      nSamples := sps * timePause div 1000;
    //
  until (false);
end;

// --  --
function thread_proc(param: Pointer): DWORD; stdcall;
var
  hp: PWaveHdr;
  bc: int;
  justPrepared: int;
begin
  bc := 0;
  while (not done) do begin
    //
    if (WAIT_OBJECT_0 = waitForSingleObject(event, 300)) then begin
      //
      justPrepared := 0;
      repeat
	//
	inc(bc);
	if (bc >= c_max_buffers) then
	  bc := 0;
	//
	prepareSine(bc);
	//
	hp := @hdr[bc];
	if (0 = (WHDR_PREPARED and hp.dwFlags)) then begin
	  //
	  // prepare header
	  hp.lpData := pAnsiChar(@buffer[bc]);
	  hp.dwBufferLength := sizeof(buffer[bc]);
	  waveOutPrepareHeader(wout, hp, sizeof(WAVEHDR));
	  //
	  inc(justPrepared);
	end;
	//
	if (0 <> (WHDR_PREPARED and hp.dwFlags)) then
	  waveOutWrite(wout, hp, sizeof(WAVEHDR))
	else
	  ; // header was not prepared
	//
      until ((0 = justPrepared) or (justPrepared >= c_max_buffers));
    end;
  end;
  //
  result := 0;
end;

// --  --
procedure fail(const msg: string);
begin
  writeln(msg, ' Error code: ', GetLastError());
end;

var
  wasKey: bool;

// --  --
function key(scancode: int): bool;
begin
  result := (0 <> (not int(high(Smallint)) and GetAsyncKeyState(scancode)));
  if (result) then begin
    //
    wasKey := true;
    Sleep(90);	// sleep a little, so keyboard events will not fire too fast
  end;
end;

// -- main --

var
  tid: cardinal;
  th: tHandle;
  fmt: tWAVEFORMATEX;
  res: int;
begin
  event := CreateEvent(nil, false, false, nil);
  if (0 <> event) then begin
    //
    // start thread
    th := createThread(nil, 0, @thread_proc, nil, 0, tid);
    if (0 <> th) then begin
      //
      // prepare wave format
      fmt.wFormatTag := 1;
      fmt.nChannels := 1;
      fmt.nSamplesPerSec := sps;
      fmt.nAvgBytesPerSec := sps shl 1;
      fmt.nBlockAlign := 2;
      fmt.wBitsPerSample := 16;
      fmt.cbSize := 0;
      //
      res := WaveOutOpen(@wout, cardinal(-1), @fmt, event, 0, CALLBACK_EVENT);
      if (MMSYSERR_NOERROR = res) then begin
	//
	writeLn('Q/A - freq;  Left/Right - pause;  Up/Down - signal;  Enter - EXIT.'#13#10);
	//
	wasKey := true;
	repeat
	  //
	  if (key(ord('Q'))) then inc(freq, 10);
	  if (key(ord('A'))) then if (freq > 100) then dec(freq, 10);
	  if (key(VK_UP)) then inc(timeSignal, 10);
	  if (key(VK_DOWN)) then if (timeSignal > 10) then dec(timeSignal, 10);
	  if (key(VK_RIGHT)) then inc(timePause, 10);
	  if (key(VK_LEFT)) then if (timePause > 10) then dec(timePause, 10);;
	  //
	  if (wasKey) then
	    write('Freq: ', freq, 'Hz;  signal: ', timeSignal, 'ms;  pause: ', timePause, 'ms '#13);
	  //
	  if (key(VK_RETURN)) then
	    break;	// done
	  //
	  wasKey := false;
	  //
	until (false);
	//
	done := true;	// tell thread we are done
	WaitForSingleObject(th, 1000);	// wait for thread to terminate
	//
	waveOutReset(wout);
	WaveOutClose(wout);
	//
	writeln('Have a nice OS.');
      end
      else
	fail('Could not open wave device (MMERROR=' + IntToStr(res) + '.');
    end
    else
      fail('Could not create thread.');
  end
  else
    fail('Could not create event.');
end.

комменты пришлось слегка порезать, чтобы влезло в 5000

[s-andriano]

Во-первых, IMHO для такой темы больше подходит раздел Мультимедиа.
Во-вторых, как раз в этом разделе в одной из недавних (несколько дней назад) тем есть ссылка на литературу, где достаточно хорошо описано, как в Windows генерить звуки неограниченной длины.