1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:
26:
27:
28:
29:
30:
31:
32:
33:
34:
35:
36:
37:
38:
39:
40:
41:
42:
43:
44:
45:
46:
47:
48:
49:
50:
51:
52:
53:
54:
55:
56:
57:
58:
59:

procedure GenerateSinus(Samples: Integer; out Data: Pointer; out Size: Integer);
var
 I: Integer;
begin
 Size := 2 * Samples;
 GetMem(Data, Size);

 For I := 0 To Samples - 1 Do
  PSmallInt(Integer(Data) + I * 2)^ := Round(Sin(I / Samples * 2 * Pi) * $7FFF);
end;

procedure GenerateSquare(Samples: Integer; out Data: Pointer; out Size: Integer);
var
 I, Address: Integer;
begin
 Size := 2 * Samples;
 GetMem(Data, Size);

 For I := 0 To Samples div 2 - 2 Do
  PSmallInt(Integer(Data) + I * 2)^ := $7FFF;
 For I := Samples div 2 - 1 To Samples - 1 Do
  PSmallInt(Integer(Data) + I * 2)^ := -$8000;
end;

procedure GenerateTriangle(Samples: Integer; out Data: Pointer; out Size: Integer);
var
 I, P1, P2: Integer;
begin
 Size := 2 * Samples;
 GetMem(Data, Size);

 P1 := Round(Samples * 0.25);
 P2 := Round(Samples * 0.75);

 For I := 0 To Samples - 1 Do
  If I < P1 Then
   PSmallInt(Integer(Data) + I * 2)^ := Round($FFFF * +2 * I / Samples)
  Else If I > P2 Then
   PSmallInt(Integer(Data) + I * 2)^ := Round($FFFF * +2 * (I / Samples - 1))
  Else
   PSmallInt(Integer(Data) + I * 2)^ := Round($FFFE * -2 * (I / Samples - 0.5));
end;

procedure GenerateNeedle(Samples: Integer; out Data: Pointer; out Size: Integer);
var
 I: Integer;
 V: Single;
begin
 Size := 2 * Samples;
 GetMem(Data, Size);

 V := Ln(1 / $7FFF) * 2;

 For I := 0 To Samples div 2 - 2 Do
  PSmallInt(Integer(Data) + I * 2)^ := Round(Exp((I / Samples - 0.0) * V) * $7FFF);
 For I := Samples div 2 - 1 To Samples - 1 Do
//  PSmallInt(Integer(Data) + I * 2)^ := EnsureRange(Round(Exp((I / Samples - 1/2) * V) * -$7FFF), -$8000, $7FFF);
  PSmallInt(Integer(Data) + I * 2)^ := Round(Exp((I / Samples - 1/2) * V) * -$7FFF);
end;                    

1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:
26:
27:
28:
29:
30:
31:
32:
33:
34:
35:
36:
37:
38:
39:
40:
41:
42:
43:
44:
45:
46:
47:
48:
49:
50:
51:
52:
53:
54:
55:
56:
57:
58:
59:
60:
61:
62:

uses MmSystem;

{...}

function _OpenMapper: HWaveOut;
var
 Fmt: TWaveFormatEx;
begin
 Fmt.cbSize          := SizeOf(Fmt);
 Fmt.wFormatTag      := Wave_Format_Pcm;
 Fmt.nChannels       := 1;
 Fmt.nSamplesPerSec  := 44100;
 Fmt.nAvgBytesPerSec := 44100 * 2 * 1;
 Fmt.nBlockAlign     := 2 * 1;
 Fmt.wBitsPerSample  := 16;
 If WaveOutOpen(@Result, Wave_Mapper, @Fmt, 0, 0, 0) <> MmSysErr_NoError Then
  ShowMessage('Error Open');
end;

function _PlayMapper(Mapper: HWaveOut; Data: Pointer; Size: Integer): TWaveHdr;
begin
 Result.lpData          := PChar(Data);
 Result.dwBufferLength  := Size;
 Result.dwBytesRecorded := 0;
 Result.dwUser          := 0;
 Result.dwFlags         := WHdr_BeginLoop Or WHdr_EndLoop;
 Result.dwLoops         := $FFFFFFFF; // ~ nahezu endlos
 Result.lpNext          := 0;
 Result.reserved        := 0;
 If WaveOutPrepareHeader(Mapper, @Result, SizeOf(Result)) <> MmSysErr_NoError Then
  ShowMessage('Error Prepare');
 If WaveOutWrite(Mapper, @Result, SizeOf(Result)) <> MmSysErr_NoError Then
  ShowMessage('Error Write');
end;

procedure _StopMapper(Mapper: HWaveOut; Header: TWaveHdr);
begin
 WaveOutReset(Mapper);
 WaveOutUnprepareHeader(Mapper, @Header, SizeOf(Header));
end;

procedure _CloseMapper(Mapper: HWaveOut);
begin
 WaveOutClose(Mapper);
end;

{...}

var
 Size: Integer;
 Data: Pointer;
 M: HWaveOut;
 H: TWaveHdr;
begin
 GenerateSinus(44100 div 1000, Data, Size); // 1kHz
 Application.ProcessMessages;
 M := _OpenMapper;
 H := _PlayMapper(M, Data, Size);
 Sleep(1000); // 1 Sekunde
 _StopMapper(M, H);
 _CloseMapper(M);
 FreeMem(Data);