Аудио - хороший пример

{*************************************************************************
  Unit:                Audio.pas

  Description:         TAudio component for accessing waveform devices

  Accessed Units:      mmSystem.pas

  Compiler:            Delphi 1.02 (16 bit) and Delphi 3 (32 bit)

  I/O:                 waveform device via Windows multimedia API

  References           - mmSystem.hlp (Win16) and mm.hlp (Win32)
                       - UDDF, Nov 1997 article "Low Level WaveIn Routine" by John Mertus
                       - UNDU, Sept 1997 article "Playing and Recording Sound in Delphi" by Darryl Gove
                       - Delphi Bug List, waveInClose error in mmSystem by Reinier Sterkenburg
                       - TJW's web site, "The Wave File Format" by Timothy J Weber
                       - Colin's web site, Mixer Control by Colin Wilson

  Conditions of usage  Freeware, use at own risk. Please report faults or comments to the author

  Author               Mr Hakan Bergzen, hakan_bergzen@hotmail.com

  Ver   Date    Made by              Change

  1.0   980106  Hakan Bergzen (HBn)  Basic version for Win16
  1.0   980117  HBn                  Converted for Win32
  2.0   980412  HBn                  Added wave file support
  3.0   980702  HBn                  Corrected errors, reworked structure and
                                     added functions
  3.0   980716  HBn                  Added Mixer Control capability (32bit only)
  3.1   980725  HBn                  Added wave_mapper, changed PlayFile procedure
                                     and changed Mixer procedures
  3.2   980823  HBn                  Extended RecordToFile functionality,
                                     corrected errors
  3.3x  9809xx-9811xx  HBn           Non-released test versions
  4.0   981122  HBn                  Fixed consecutive playing of files,
                                           stop while playing,
                                           callback_function under WindowsNT,
                                     modified PlayFile for various wav file formats,
                                              Mixer functions internally,
                                     added Meter reading,
                                           OnMixerChange event,
                                           Mixer status in Query,
                                     faster start-up time in Play when using Left and Right TStreams,
                                            TrigLevel and Split (in assembler),
                                     less RAM required (PlayStream changed from
                                                        MemoryStream to FileStream),
                                     fewer user instructions (no more need to use Open
                                                        and Close from the application)
  4.1   990322  HBn                  Removed faults causing Delphi/Windows to crash
                                     in some installations
**************************************************************************}

Unit
 Audio;

interface


uses

  SysUtils, WinTypes, WinProcs, Messages, Forms, Classes,
  mmSystem;

type

   TChannels = (Mono, Stereo);
   TBPS = (_8,_16);

const

   DefaultAudioDeviceID = WAVE_MAPPER;
   No_Buffers = 4;
   ChannelsDefault = Mono;
   BPSDefault = _8;
   SPSDefault = 11025;
   NoSamplesDefault = 8192;

{$IFDEF WIN32}
   DefaultMixerDeviceID = 0;
   Ver = '4.1 (32bit)';
{$ELSE}
   Ver = '4.1 (16bit)';
{$ENDIF}

type

  TNotifyAudioRecordEvent = procedure
(Sender: TObject; LP,RP: Pointer; BufferSize: Word) of
 object
;
  TNotifyBufferPlayedEvent = procedure
(Sender: TObject) of
 object
;
  TNotifyPlayedEvent = procedure
(Sender: TObject) of
 object
;
{$IFDEF WIN32}
  TNotifyMixerChange = procedure
(Sender:TObject;Destination,Source: Word) of
 object
;
{$ENDIF}

  TAudio = class
;

{$IFDEF WIN32}
  ValuesArray = array
 [0..1] of
 integer;
  PMixDetails = ^TMixDetails;
  TMixDetails = record

                 Destination,Source : Word;
                 Name : string
;
                 VolControlID,MuteControlID, MeterControlID : dword;
                 Left, Right, Meter : Word;
                 CtrlType : Word;
                 Mute, Mono, Speakers, Available : boolean;
                 Next:PMixDetails;
                end
;

  TMixerSettings = class
(TPersistent)
  private

    FAudio              : TAudio;
    MixerHandle         : HMIXER;
    MixerStart          : PMixDetails;
    MixerReady          : boolean;
    MixerCallbackHandle : HWND;
    FList               : TStrings;
    procedure
 InitiateControlDetails(var
 details:TMixerControlDetails;
              ControlID,Channels:dword; pvalues:pointer);
    function
 GetMixerSettings(MixerDeviceID:integer):boolean;
    procedure
 MixerCallBack(var
 Msg:TMessage);
  public

    function
 GetName(Dest,Source:Word):string
;
    function
 SetControl(Dest,Source:Word; LeftVolume,RightVolume:Word; Mute:boolean):boolean;
    function
 GetControl(Dest,Source:Word; var
 LeftVolume,RightVolume:Word; var
 Mute:boolean; var
 CtrlType:byte):boolean;
    function
 GetMeter(Dest,Source:Word; var
 LeftVolume,RightVolume:dword):boolean;
    function
 GetSources(Dest:Word):TStrings;
    function
 GetDestinations:TStrings;
    function
 Query(var
 Product,Formats:string
):boolean;
  end
;
{$ENDIF}

  TAudioSettings = class
(TPersistent)
  private

    FAudio               : TAudio;
    pWaveHeader          : array
 [0..No_Buffers-1] of
 PWAVEHDR;
    pWaveBuffer          : array
 [0..No_Buffers-1] of
 pointer;
    pExtraBuffer         : array
 [0..No_Buffers-1] of
 pointer;  {Used to carry Right samples during Split channels}
    ForwardIndex         : Integer;
    ReturnIndex          : Integer;
    ActiveBuffers        : Integer;
    DeviceOpen           : Boolean;
  private

    FChannels            : TChannels;
    FBPS                 : TBPS;
    FSPS                 : Word;
    FNoSamples           : Word;
{$IFDEF WIN32}
    pWaveFmt             : pWaveFormatEx;
{$ELSE}
    pWaveFmt             : pPCMWaveFormat;
{$ENDIF}
    WaveBufSize          : Word;
    procedure
 SetChannels(Value:TChannels);
    procedure
 SetBPS(Value:TBPS);
    procedure
 SetSPS(Value:Word);
    procedure
 InitWaveHeaders;
    function
 AllocateMemory: Boolean;
    procedure
 FreeMemory;
  public

    Active               : Boolean;
  published

    property
 BitsPerSample: TBPS read
 FBPS write
 SetBPS default
 BPSDefault
;
    property
 Channels: TChannels read
 FChannels write
 SetChannels default
 ChannelsDefault
;
    property
 SampleRate: Word read
 FSPS write
 SetSPS default
 SPSDefault
;
  end
;

  PRecorder = ^TRecorder;
  TRecorder = class
(TAudioSettings)
  private

    WaveIn                   : HWAVEIN;
    FPause                   : Boolean;
    FSplit                   : Boolean;
    FTrigLevel               : Word;
    FTriggered               : Boolean;
    RecStream                : TFileStream;
    RecToFile                : Boolean;
    AddNextInBufferHandle    : hWnd;
    procedure
 AddNextInBuffer2(var
 Msg: TMessage);
    function
 AddNextInBuffer: Boolean;
    procedure
 SetTrigLevel(Value:Word);
    function
 TestTrigger(StartPtr:pointer; Size:Word):boolean;
    procedure
 SetSplit(Value:Boolean);
    procedure
 Split(var
 LP,RP:pointer; var
 Size:Word);
    procedure
 GetError(iErr : Integer; Additional:string
);
    procedure
 SetNoSamples(Value:Word);
    function
  Open : boolean;
    function
 Close : boolean;
  public

    function
  Start : boolean;
    function
 Stop : boolean;
    procedure
 Pause;
    procedure
 Restart;
    procedure
 RecordToFile(FileName:string
; LP,RP:TStream);
  published

    property
 NoSamples: Word read
 FNoSamples write
 SetNoSamples default
 NoSamplesDefault
;
    property
 SplitChannels: Boolean read
 FSplit write
 SetSplit default
 false;
    property
 TrigLevel: Word read
 FTrigLevel write
 SetTrigLevel default
 128;
    property
 Triggered: Boolean read
 FTriggered write
 FTriggered default
 true;
  end
;

  PPlayer = ^TPlayer;
  TPlayer = class
(TAudioSettings)
  private

    WaveOut                : HWAVEIN;
    FNoOfRepeats           : Word;
    ReadPlayStreamPos      : LongInt;
    PlayStream             : TFileStream;
    FPlayFile              : boolean;
    PlayFileStream         : TFileStream;
    FOldChannels            : TChannels;
    FOldBPS                 : TBPS;
    FOldSPS                 : Word;
    FinishedPlaying         : boolean;
    AddNextOutBufferHandle  : hWnd;
    CloseHandle             : hWnd;
    procedure
 AddNextOutBuffer2(var
 Msg: TMessage);
    procedure
 Close2(var
 Msg: TMessage);
    function
  Open : boolean;
    procedure
 GetError(iErr : Integer; Additional:string
);
    function
 AddNextOutBuffer:longint;
  public

    procedure
 SetVolume(LeftVolume,RightVolume:Word);
    procedure
 GetVolume(var
 LeftVolume,RightVolume:Word);
    procedure
 Play(LP,RP:TStream; NoOfRepeats:Word);
    procedure
 Stop;
    procedure
 Pause;
    procedure
 Reset;
    procedure
 Restart;
    procedure
 BreakLoop;
    function
 PlayFile(FileName:string
; NoOfRepeats:Word):boolean;
  published

  end
;

  TAudio = class
(TComponent)
  private

    FVersion             : string
;
    FDeviceID            : Integer;
    FSepCtrl             : Boolean;
    procedure
 SetDeviceID(Value:Integer);
    procedure
 SetVersion(Value:string
);
  private

    FOnAudioRecord       : TNotifyAudioRecordEvent;
    FRecorder            : TRecorder;
  private

    FOnBufferPlayed      : TNotifyBufferPlayedEvent;
    FOnPlayed            : TNotifyPlayedEvent;
    FPlayer              : TPlayer;
  private

    FWindowHandle        : HWND;
    WaveFmtSize          : Integer;
{$IFDEF WIN32}
    FMixerDeviceID       : Integer;
    FOnMixerChange       : TNotifyMixerChange;
    procedure
 SetMixerDeviceID(Value:Integer);
{$ENDIF}
    procedure
 AudioCallBack(var
 Msg: TMessage);export;
   public

{$IFDEF WIN32}
    Mixer                : TMixerSettings;
{$ENDIF}
    ErrorMessage         : string
;
    constructor
 Create(AOwner: TComponent); override
;
    destructor
  Destroy; override
;
    function
 Query(var
 Product,Formats:string
):boolean;
  published

    property
 AudioDeviceID: Integer read
 FDeviceID write
 SetDeviceID default
 DefaultAudioDeviceID;
{$IFDEF WIN32}
    property
 MixerDeviceID: Integer read
 FMixerDeviceID write
 SetMixerDeviceID default
 DefaultMixerDeviceID;
{$ENDIF}
    property
 SeparateCtrls: Boolean read
 FSepCtrl write
 FSepCtrl default
 false;
    property
 Player: TPlayer read
 FPlayer write
 FPlayer;
    property
 Recorder: TRecorder read
 FRecorder write
 FRecorder;
    property
 Version: string read
 FVersion write
 SetVersion;

    property
 OnRecord: TNotifyAudioRecordEvent read
 FOnAudioRecord write
 FOnAudioRecord;
    property
 OnBufferPlayed: TNotifyBufferPlayedEvent read
 FOnBufferPlayed write
 FOnBufferPlayed;
    property
 OnPlayed: TNotifyPlayedEvent read
 FOnPlayed write
 FOnPlayed;
{$IFDEF WIN32}
    property
 OnMixerChange:TNotifyMixerChange read
 FOnMixerChange write
 FOnMixerChange;
{$ENDIF}
  end
;
{$IFDEF WIN32}
{$ELSE}
  function
 CorrectedwaveInClose(hWaveIn: HWaveIn): Word;
{$ENDIF}

  procedure
 Register
;

implementation


{$IFDEF WIN32}
{$ELSE}
function
 CorrectedwaveInClose; external
 'MMSYSTEM' index 505;
{$ENDIF}
{------------- WinAPI CallBack routines --------------------------------}
{ Callback routine used for CALLBACK_WINDOW in waveInOpen and waveOutOpen    }
procedure
 TAudio.AudioCallBack(var
 Msg: TMessage);
var
 LP,RP:pointer;
    Size:Word;
begin

  case
 Msg.Msg of

    mm_wim_OPEN  : FRecorder.Active:=true
;
    mm_wim_CLOSE : FRecorder.Active:=false
;
    mm_wim_DATA  : begin

                     if
 FRecorder.Active then
 begin

                       LP:=FRecorder.pWaveBuffer[FRecorder.ReturnIndex Mod
 No_Buffers];
                       RP:=FRecorder.pExtraBuffer[FRecorder.ReturnIndex Mod
 No_Buffers];
                       Size:=FRecorder.pWaveHeader[FRecorder.ReturnIndex Mod
 No_Buffers]^.dwBytesRecorded;
                       if
 (not
(FRecorder.FPause) and
 FRecorder.TestTrigger(LP,Size)) then
 begin

                              if
 FRecorder.RecToFile then
 FRecorder.RecStream.write(LP^,Size);
                              if
 Assigned(FOnAudioRecord) then
 begin

                                if
 FRecorder.FSplit then
 begin

                                  FRecorder.Split(LP,RP,Size);
                                  FOnAudioRecord(Self,LP,RP,Size);
                                end
 else
 FOnAudioRecord(Self,LP,nil
,Size);
                              end
;
                       end
;
                       if
 (Size>0) then
 begin

                            PostMessage(FRecorder.AddNextInBufferHandle,wim_DATA,0,0);
   {                         FRecorder.AddNextInBuffer;       }
                            FRecorder.ReturnIndex:=(FRecorder.ReturnIndex+1) mod
 No_Buffers;
                       end
;
                     end
;
                   end
;
    mm_wom_OPEN  : FPlayer.Active:=true
;
    mm_wom_CLOSE : FPlayer.Active:=false
;
    mm_wom_DONE  : if
 FPlayer.Active then
 begin

                     if
 (FPlayer.ForwardIndex=FPlayer.ReturnIndex) then
 begin

                       if
 not
(FPlayer.FinishedPlaying) then
 begin

                         FPlayer.FinishedPlaying:=true
;
                         PostMessage(FPlayer.CloseHandle,mm_wom_CLOSE,0,0);
                       end
;
                     end
 else
 begin

                       if
 Assigned(FOnBufferPlayed) then
 FOnBufferPlayed(Self);
                       PostMessage(FPlayer.AddNextOutBufferHandle,wom_DONE,0,0);
                       FPlayer.ReturnIndex:=(FPlayer.ReturnIndex+1) mod
 No_Buffers;
                       dec(FPlayer.ActiveBuffers);
                     end
;
                   end
;
    wm_QueryEndSession : Destroy;    { only called if Callback_Window is used }
  end
;
end
;
{------------- Internal/Private routines -------------------------------}

procedure
 TAudioSettings.InitWaveHeaders;
var

  i : Integer;
begin

  for
 i:=0 to
 No_Buffers-1 do
 begin

    pWaveHeader[i]^.lpData:=pWaveBuffer[i];
    pWaveHeader[i]^.dwBufferLength:=WaveBufSize;
    pWaveHeader[i]^.dwBytesRecorded:=0;
    pWaveHeader[i]^.dwUser:=0;
    pWaveHeader[i]^.dwFlags:=0;
    pWaveHeader[i]^.dwLoops:=0;
    pWaveHeader[i]^.lpNext:=nil
;
    pWaveHeader[i]^.reserved:=0;
  end
;
end
;

function
 TAudioSettings.AllocateMemory: Boolean;
var

  i : Integer;
begin

    pWaveFmt:=nil
;
    try

      GetMem(pWaveFmt,FAudio.WaveFmtSize);
    except

      FAudio.ErrorMessage:='Not enough memory to allocate WaveFormat';
      Result:=false
;
      Exit;
    end
;
    if
 FBPS=_8 then
 pWaveFmt^.wBitsPerSample :=8
    else
 pWaveFmt^.wBitsPerSample :=16;
{$IFDEF WIN32}
    pWaveFmt^.cbSize:=0;
    with
 pWaveFmt^ do
 begin

{$ELSE}
    with
 pWaveFmt^.wf do
 begin

{$ENDIF}
      wFormatTag:=WAVE_FORMAT_PCM;
      if
 FChannels=Mono then
 nChannels:=1
      else
 nChannels:=2;
      nSamplesPerSec:=FSPS;
{ BlockAlign : e.g. 16-bit stereo PCM => 4 = 2 channels x 2 bytes/channel    }
      if
 FBPS=_8 then
 nBlockAlign:=(8 div
 8)*nChannels
      else
 nBlockAlign:=(16 div
 8)*nChannels;
      nAvgBytesPerSec:=nSamplesPerSec*nBlockAlign;
      WaveBufSize:=FNoSamples*nBlockAlign;
    end
;

    for
 i:=0 to
 No_Buffers-1 do
 begin

      pWaveHeader[i]:=nil
;
      try

        GetMem(pWaveHeader[i],sizeof(TWAVEHDR));
      except

        FAudio.ErrorMessage:='Not enough memory to allocate WaveHeader';
        Result:=false
;
        Exit;
      end
;
      pWaveBuffer[i]:=nil
;
      pExtraBuffer[i]:=nil
;
      try

        GetMem(pWaveBuffer[i],WaveBufSize);
        GetMem(pExtraBuffer[i],(WaveBufSize div
 2));
      except

        FAudio.ErrorMessage:='Not enough memory to allocate Wave Buffer';
        Result:=false
;
        Exit;
      end
;
      pWaveHeader[i]^.lpData:=pWaveBuffer[i];
    end
;
    Result:=true
;
end
;

procedure
 TAudioSettings.FreeMemory;
var

  i : Integer;
begin

  if
 (pWaveFmt = nil
) then
 Exit
  else
 begin

    FreeMem(pWaveFmt,FAudio.WaveFmtSize);
    pWaveFmt:=nil
;
  end
;
  for
 i:=0 to
 No_Buffers-1 do
 begin

    if
 (pWaveBuffer[i]<>nil
) then
 FreeMem(pWaveBuffer[i],WaveBufSize);
    pWaveBuffer[i]:=nil
;
    if
 (pExtraBuffer[i]<>nil
) then
 FreeMem(pExtraBuffer[i],(WaveBufSize div
 2));
    pExtraBuffer[i]:=nil
;
    if
 (pWaveHeader[i]<>nil
) then
 FreeMem(pWaveHeader[i],sizeof(TWAVEHDR));
    pWaveHeader[i]:=nil
;
  end
;
end
;

function
 TRecorder.TestTrigger(StartPtr:pointer; Size:Word):boolean;
var

{$IFDEF WIN32}
    i : longint;
    j :boolean;
    k : Word;
{$ELSE}
    BytesCounted : Word;
    pb : ^byte;
    ip : ^smallint;
{$ENDIF}
begin

{$IFDEF WIN32}
  if
 not
(FTriggered) and
 (Size>0) then
 begin

    j:=FTriggered;
    i:=Size;
    k:=FTrigLevel;
    if
 FBPS=_8 then
 begin

asm

    mov eax,StartPtr
    mov ecx,i
    mov edx,0
@trig8:
    mov dl,[eax]
    cmp dx,k
    jge @out8
    add eax,1
    pop ecx
    loop @trig8
    jmp @out88
@out8:
    mov j,1
@out88:
end
;
    end
 else
 begin

asm

    mov eax,StartPtr
    mov ecx,i
    shr
 ecx,1
    mov edx,0
@trig16:
    mov dx,[eax]
    cmp dx,k
    jge @out16
    add eax,2
    loop @trig16
    jmp @out16a
@out16:
    mov j,1
@out16a:
end
;
    end
;
    FTriggered:=j;
  end
;
{$ELSE}
  if
 not
(FTriggered) and
 (Size>0) then
 begin

    if
 FBPS=_8 then
 begin

      pb:=StartPtr;
      repeat

         if
 pb^>TrigLevel then
 FTriggered:=true
;
         inc(pb);
         inc(BytesCounted);
      until
 (BytesCounted>=Size) or
 FTriggered;
    end
 else
 begin

      ip:=StartPtr;
      repeat

         if
 ip^>TrigLevel then
 FTriggered:=true
;
         inc(ip);
         inc(BytesCounted,2);
      until
 (BytesCounted>=Size) or
 FTriggered;
    end
;
  end
;
{$ENDIF}
  Result:=FTriggered;
end
;

procedure
 TRecorder.Split(var
 LP,RP:pointer; var
 Size:Word);
var

    i : longint;
    lb,rb,pb : ^byte;
begin

 if
 (Size>0) then
 begin

  Size:=Size div
 2;
  lb:=LP; rb:=RP;
  pb:=LP;
{$IFDEF WIN32}
  i:=Size;
  if
 FBPS=_8 then
 begin

asm

    mov eax,lb
    mov ecx,i
    mov edx,rb
@split8:
    push ecx
    mov ecx,pb
    mov cx,[ecx]
    mov [eax],cl
    mov [edx],ch
    add dword ptr [pb],2
    add eax,1
    add edx,1
    pop ecx
    loop @split8
end
;
  end
 else
 begin

asm

    mov eax,lb
    mov ecx,i
    shr
 ecx,1
    mov edx,rb
@split16:
    push ecx
    mov ecx,pb
    mov ecx,[ecx]
    mov [eax],cx
    shr
 ecx,16
    mov [edx],cx
    add dword ptr [pb],4
    add eax,2
    add edx,2
    pop ecx
    loop @split16
end
;
  end
;
{$ELSE}
{ The lines below are replaced with the asm routine above
  starting from (and including) i:=Size       }
  if
 FBPS=_8 then
 begin

    for
 i:=1 to
 Size do
 begin

       lb^:=pb^; inc(lb);inc(pb);
       rb^:=pb^; inc(rb);inc(pb);
    end
;
  end
 else
 begin

    for
 i:=1 to
 (Size div
 2) do
 begin

       lb^:=pb^; inc(lb);inc(pb);
       lb^:=pb^; inc(lb);inc(pb);
       rb^:=pb^; inc(rb);inc(pb);
       rb^:=pb^; inc(rb);inc(pb);
    end
;
  end
;
{$ENDIF}
 end
;
end
;

procedure
 TRecorder.AddNextInBuffer2(var
 Msg: TMessage);
begin

   if
 (Msg.Msg=wim_DATA) and
 DeviceOpen then
 AddNextInBuffer;
end
;

function
 TRecorder.AddNextInBuffer: Boolean;
var

  iErr : Integer;
begin

   iErr:=waveInAddBuffer(WaveIn, pwaveheader[ForwardIndex], sizeof(TWAVEHDR));
   if
 (iErr<>0) then
 begin

       Stop;
       GetError(iErr,'Error adding input buffer');
       Result:=false
;
       Exit;
   end
;
   ForwardIndex:=(ForwardIndex+1) mod
 No_Buffers;
   Result:=true
;
end
;

procedure
 TRecorder.GetError(iErr : Integer; Additional:string
);
var

  ErrorText : string
;
  pError : PChar;
begin

  GetMem(pError,256*2);   { make sure there is ample space if WideChar is used }
  waveInGetErrorText(iErr,pError,255);
  ErrorText:=StrPas(pError);
  FreeMem(pError,256*2);
  if
 length(ErrorText)=0 then
 FAudio.ErrorMessage:=Additional
  else
 FAudio.ErrorMessage:=Additional+' '+ErrorText;
end
;

procedure
 TPlayer.AddNextOutBuffer2(var
 Msg: TMessage);
begin

   if
 (Msg.Msg=wom_DONE) and
 DeviceOpen then
 AddNextOutBuffer;
end
;

function
 TPlayer.AddNextOutBuffer:longint;
var
  iErr:integer;
     WritePos:Longint;
begin

  if
 (PlayStream<>nil
) then
 begin

    FinishedPlaying:=false
;
    WritePos:=PlayStream.Position;
    PlayStream.Position:=ReadPlayStreamPos;
    Result:=PlayStream.Read
(pwaveheader[ForwardIndex]^.lpData^,WaveBufSize);
    if
 (Result=0) and
 (FNoOfRepeats>0) then
 begin

      dec(FNoOfRepeats,1);
      PlayStream.Position:=0;
      Result:=PlayStream.Read
(pwaveheader[ForwardIndex]^.lpData^,WaveBufSize);
    end
;
    ReadPlayStreamPos:=PlayStream.Position;
    PlayStream.Position:=WritePos;
    if
 Result>0 then
 begin

      pwaveheader[ForwardIndex]^.dwBufferLength:=Result;
      pwaveheader[ForwardIndex]^.dwFlags:=0;
      pwaveheader[ForwardIndex]^.dwLoops:=0;
      iErr:=waveOutPrepareHeader(WaveOut,pWaveHeader[ForwardIndex],sizeof(TWAVEHDR));
      if
 iErr<>0 then
 begin

        GetError(iErr,'');
        Exit;
      end
;
      iErr:=waveOutWrite(WaveOut, pwaveheader[ForwardIndex], sizeof(TWAVEHDR));
      if
 iErr<>0 then
 begin

        GetError(iErr,'');
        Exit;
      end
;
      ForwardIndex:=(ForwardIndex+1) mod
 No_Buffers;
      inc(ActiveBuffers);
    end
 else
 begin

      PlayStream.Free;
      PlayStream:=nil
;
    end
;
  end
 else
 Result:=0;
end
;

procedure
 TPlayer.GetError(iErr : Integer; Additional:string
);
var

  ErrorText : string
;
  pError : PChar;
begin

  GetMem(pError,256*2);   { make sure there is ample space if WideChar is used }
  waveOutGetErrorText(iErr,pError,255);
  ErrorText:=StrPas(pError);
  FreeMem(pError,256*2);
  if
 length(ErrorText)=0 then
 FAudio.ErrorMessage:=Additional
  else
 FAudio.ErrorMessage:=Additional+' '+ErrorText;
end
;

{$IFDEF WIN32}
{ Mixer Controls only available in the 32bit version          }
procedure
 TMixerSettings.InitiateControlDetails(var
 details:TMixerControlDetails;
              ControlID,Channels:dword; pvalues:pointer);
begin

 details.cbStruct := sizeof (details);
 details.dwControlID := ControlID;
 details.cChannels := Channels;
 details.cMultipleItems := 0;
 details.cbDetails := sizeof (dword);
 details.paDetails := pvalues;
end
;

function
 TMixerSettings.SetControl(Dest,Source:Word; LeftVolume,RightVolume:Word; Mute:boolean):boolean;
var
 P:PMixDetails;
    err : integer;
    values : ValuesArray;
    details : TMixerControlDetails;
begin

  Result:=false
;
  P:=MixerStart;
  if
 MixerReady then
 begin

    while
 (P<>nil
) do
 begin

      if
 ((P^.Destination=Dest) and
 (P^.Source=Source)) then
 begin

        if
 P^.VolControlID<65535 then
 begin

          if
 P^.Mono then
 begin

            InitiateControlDetails(details,P^.VolControlID,1,@values);
          end
 else
 begin

            InitiateControlDetails(details,P^.VolControlID,2,@values);
          end
;
          values[0]:= LeftVolume;
          values[1]:= RightVolume;
          err := mixerSetControlDetails (MixerHandle, @details, MIXER_SETCONTROLDETAILSF_VALUE);
          if
 err<>MMSYSERR_NOERROR then
 begin

            FAudio.ErrorMessage:='Volume SetControlError in Mixer';
            exit;
          end
;
        end
;
        if
 P^.MuteControlID<65535 then
 begin

          InitiateControlDetails(details,P^.MuteControlID,1,@values);
          if
 Mute then
 values[0]:= 1
          else
 values[0]:=0;
          err := mixerSetControlDetails (MixerHandle, @details, MIXER_SETCONTROLDETAILSF_VALUE);
          if
 err<>MMSYSERR_NOERROR then
 begin

            FAudio.ErrorMessage:='Mute SetControlError in Mixer';
            exit;
          end
 else
 Result:=true
;
        end
 else
 Result:=true
;
        Exit;
      end
;
      P:=P^.Next;
    end
;
  end
;
end
;

function
 TMixerSettings.GetControl(Dest,Source:Word; var
 LeftVolume,RightVolume:Word;
                                   var
 Mute:boolean; var
 CtrlType:byte):boolean;
var
 P:PMixDetails;
    err : integer;
    values : ValuesArray;
    details : TMixerControlDetails;
begin

  Result:=false
;
  P:=MixerStart;
  if
 MixerReady then
 begin

    while
 (P<>nil
) do
 begin

      if
 ((P^.Destination=Dest) and
 (P^.Source=Source)) then
 begin

        CtrlType:=byte(P^.CtrlType);
        if
 P^.Mono then
 InitiateControlDetails(details,P^.VolControlID,1,@values)
        else
 InitiateControlDetails(details,P^.VolControlID,2,@values);
        err := mixerGetControlDetails (MixerHandle, @details, MIXER_GETCONTROLDETAILSF_VALUE);
        if
 err<>MMSYSERR_NOERROR then
 begin

          FAudio.ErrorMessage:='Volume GetControlError in Mixer';
          exit;
        end
;
        LeftVolume:=values[0];
        if
 P^.Mono then
 RightVolume:=LeftVolume
        else
 RightVolume:=values[1];
         InitiateControlDetails(details,P^.MuteControlID,1,@values);
        err := mixerGetControlDetails (MixerHandle, @details, MIXER_GETCONTROLDETAILSF_VALUE);
        if
 err<>MMSYSERR_NOERROR then
 begin

          FAudio.ErrorMessage:='Mute GetControlError in Mixer';
          exit;
        end
;
        if
 values[0]=0 then
 Mute:=false

        else
 Mute:=true
;
        Result:=true
;
        Exit;
      end
;
      P:=P^.Next;
    end
;
  end
;
end
;

function
 TMixerSettings.GetMeter(Dest,Source:Word; var
 LeftVolume,RightVolume:dword):boolean;
var
 P:PMixDetails;
    err : integer;
    values, val2: PMixerControlDetailsSigned;
    details : TMixerControlDetails;
begin

  Result:=false
;
  P:=MixerStart;
  if
 MixerReady then
 begin

    while
 (P<>nil
) do
 begin

      if
 ((P^.Destination=Dest) and
 (P^.Source=Source) and
 (P^.Meter>0)) then
 begin

        GetMem(values, 2*SizeOf(TMixerControlDetailsSigned));
        InitiateControlDetails(details,P^.MeterControlID,P^.Meter,values);
        err := mixerGetControlDetails (MixerHandle, @details, MIXER_GETCONTROLDETAILSF_VALUE);
        if
 err<>MMSYSERR_NOERROR then
 exit;
        val2:=values;
        LeftVolume:=val2^.lValue;
        if
 P^.Meter=1 then
 RightVolume:=LeftVolume
        else
 begin

          inc(val2);
          RightVolume:=val2^.lValue;
        end
;
        Result:=true
;
        FreeMem(values, 2*SizeOf(TMixerControlDetailsSigned));
        Exit;
      end
;
      P:=P^.Next;
    end
;
  end
;
end
;

function
 TMixerSettings.GetName(Dest,Source:Word):string
;
var
 P:PMixDetails;
begin

  Result:='';
  if
 MixerReady then
 begin

    P:=MixerStart;
    while
 (P<>nil
) do
 begin

      if
 ((P^.Destination=Dest) and
 (P^.Source=Source)) then
 begin

        Result:=P^.Name;
        Exit;
      end
;
      P:=P^.Next;
    end
;
  end
;
end
;

function
 TMixerSettings.GetSources(Dest:Word):TStrings;
var
 P:PMixDetails;
begin

  P:=MixerStart;
  FList.Clear;
  if
 MixerReady then
 begin

    while
 P<>nil
 do
 begin

      if
 (P^.Destination=Dest) then
 begin

        if
 P^.Available then
 FList.Insert(P^.Source,P^.Name)
        else
 FList.Insert(P^.Source,'');
      end
;
      P:=P^.Next;
    end
;
  end
;
  Result:=FList;
end
;

function
 TMixerSettings.GetDestinations:TStrings;
var
 P:PMixDetails;
begin

  P:=MixerStart;
  FList.Clear;
  if
 MixerReady then
 begin

    while
 P<>nil
 do
 begin

      if
 (P^.Source=0) then
 FList.Insert(P^.Destination,P^.Name);
      P:=P^.Next;
    end
;
  end
;
  Result:=FList;
end
;

function
 TMixerSettings.Query(var
 Product,Formats:string
):boolean;
var

  PMix : PMixDetails;
  i : integer;
begin

  Result:=false
;
  Product:=''; Formats:='';
  if
 MixerReady then
 begin

    if
 (mixerGetNumDevs=0) then
 begin

      Formats:='Mixer not present';
    end
 else
 begin

      PMix:=MixerStart;
      if
 PMix<>nil
 then
 Product:=PMix.Name;
      Formats:='Mixer devices present: '+IntToStr(mixerGetNumDevs)+'. DeviceID '+
               IntToStr(FAudio.FMixerDeviceID)+' has:';
      i:=0; PMix:=PMix^.Next;
      while
 PMix<>nil
 do
 begin

        if
 (PMix.Destination=i) then
 begin

          Formats:=Formats+#13#10+PMix.Name+': ';
          i:=i+1;
        end
 else
 begin

          Formats:=Formats+PMix.Name+', ';
        end
;
        PMix:=PMix^.Next;
      end
;
      Result:=true
;
    end
;
  end
;
end
;

procedure
 TMixerSettings.MixerCallBack(var
 Msg:TMessage);
var
 P : PMixDetails;
    Found : boolean;
begin

  if
 (Msg.Msg = MM_MIXM_CONTROL_CHANGE) and
 MixerReady then
 begin

    if
 (Assigned(FAudio.OnMixerChange)) then
 begin

      FAudio.OnMixerChange(Self,word(Msg.wParam),word(Msg.lParam));
      Found:=false
;
      P:=MixerStart;
      while
 (P<>nil
) and
 not
(Found) do
 begin

        if
 (P^.VolControlID=Msg.lParam) or
 (P^.MuteControlID=Msg.lParam) then
 begin

          Found:=true
;
          FAudio.OnMixerChange(Self,P^.Destination,P^.Source);
        end
;
        P:=P^.Next;
      end
;
    end
;
  end
;
end
;

function
 TMixerSettings.GetMixerSettings(MixerDeviceID:integer):boolean;
var

  j, k, err : Integer;
  caps : TMixerCaps;
  lineInfo, connectionInfo : TMixerLine;
  PMix:PMixDetails;
  Data : ValuesArray;
  speakers : boolean;

procedure
 UpdateLinkedList(Update:Word; var
 P:PMixDetails; Destination, Source : dword; Name : string
;
                           ControlID : dword; Data : ValuesArray; Mono, Speakers:boolean);
var

   TempDest,TempSource : word;
begin

 if
 (P<>nil
) or
 (Update=0) then
 begin

  case
 Update of

  0 : begin

        new(P);
        P^.Next:=nil
; P^.Available:=false
; P^.Mono:=false
;
        P^.Destination:=65535;
        P^.Source:=65535;
        P^.Name:=Name;
        P^.Speakers:=Speakers;
        P^.VolControlID:=65535; P^.Left:=0; P^.Right:=0;
        P^.MuteControlID:=65535; P^.Mute:=false
;
        P^.MeterControlID:=65535; P^.Meter:=0;
        P^.CtrlType:=0;
      end
;
  1 : begin

        TempDest:=P^.Destination; TempSource:=P^.Source;
        new(P^.Next); P:=P^.Next;
        P^.Next:=nil
; P^.Available:=false
; P^.Mono:=false
;
        if
 (word(Destination)<>TempDest) then
 begin

          TempDest:=word(Destination);
          TempSource:=0;
        end
 else
 TempSource:=(TempSource+1) mod
 65536;
        P^.Destination:=TempDest; P^.Source:=TempSource;
        P^.Name:=Name;
        P^.Speakers:=Speakers;
        P^.VolControlID:=65535; P^.Left:=0; P^.Right:=0;
        P^.MuteControlID:=65535; P^.Mute:=false
;
        P^.MeterControlID:=65535; P^.Meter:=0;
        P^.CtrlType:=128;
      end
;
  2 : begin

       if
 P^.MuteControlID=65535 then
 begin

         P^.MuteControlID:=ControlID;
         if
 Data[0]=0 then
 P^.Mute:=false

         else
 P^.Mute:=true
;
         P^.Available:=true
;
         P^.CtrlType:=(P^.CtrlType and
 127);
       end
;
      end
;
  3 : begin

       P^.VolControlID:=ControlID;
       P^.Left:=Data[0];
       if
 Mono then
 begin

         P^.Mono:=true
;
         P^.CtrlType:=P^.CtrlType+64;
       end
 else
 P^.Right:=Data[1];
       P^.Available:=true
;
      end
;
  4 : begin

       P^.MeterControlID:=ControlID;
       if
 Mono then
 P^.Meter:=1
       else
 P^.Meter:=2;
      end
;
  end
;
 end
;
end
;

function
 GetControl(var
 PMixer:PMixDetails; MixLine:TMixerLine; speakers:boolean):boolean;
var
 err,j:integer;
  mixerLineControls : TMixerLineControls;
  p, controls : PMixerControl;
  details : TMixerControlDetails;
  values : ValuesArray;
begin

   UpdateLinkedList(1,PMixer,MixLine.dwDestination,MixLine.dwSource,
      StrPas(MixLine.szName),word(MixLine.dwComponentType),Data,false
,speakers);
   mixerLineControls.cbStruct := sizeof (mixerLineControls);
   mixerLineControls.dwLineID := MixLine.dwLineID;
   mixerLineControls.cControls := MixLine.cControls;
   mixerLineControls.cbmxctrl := sizeof (TMixerControl);
   if
 MixLine.cControls>0 then
 begin

     GetMem (controls, sizeof (TMixerControlW) * MixLine.cControls);  { make sure to reserve ample space even for WideChar }
     mixerLineControls.pamxctrl := controls;
     err:=mixerGetLineControls (MixerHandle, @mixerLineControls, MIXER_GETLINECONTROLSF_ALL);
     if
  err=MMSYSERR_NOERROR then
 begin

       p := controls;
       for
 j := 0 to
 mixerLineControls.cControls - 1 do
 begin

         if
 (p^.dwControlType=MIXERCONTROL_CONTROLTYPE_VOLUME) then
 begin

            InitiateControlDetails(details,p^.dwControlID,MixLine.cChannels,@values);
            if
 mixerGetControlDetails (MixerHandle, @details, MIXER_GETCONTROLDETAILSF_VALUE) = MMSYSERR_NOERROR then

              UpdateLinkedList(3,PMixer,0,0,'',details.dwControlID,values,(MixLine.cChannels=1),speakers);
         end
 else
 begin

           if
 (p^.dwControlType=MIXERCONTROL_CONTROLTYPE_MUTE) then
 begin

            InitiateControlDetails(details,p^.dwControlID,1,@values);
            if
 mixerGetControlDetails (MixerHandle, @details, MIXER_GETCONTROLDETAILSF_VALUE) = MMSYSERR_NOERROR then

              UpdateLinkedList(2,PMixer,0,0,'',details.dwControlID,values,false
,speakers);
           end
 else
 begin

              if
 (p^.dwControlType=MIXERCONTROL_CONTROLTYPE_PEAKMETER) then
 begin

                InitiateControlDetails(details,p^.dwControlID,MixLine.cChannels,@values);
                if
 mixerGetControlDetails (MixerHandle, @details, MIXER_GETCONTROLDETAILSF_VALUE) = MMSYSERR_NOERROR then

                  UpdateLinkedList(4,PMixer,0,0,'',details.dwControlID,values,(MixLine.cChannels=1),speakers);
              end
;
           end
;
         end
;
         Inc (p);
       end
;
       Result:=true
;
     end
 else
 Result:=false
;
     FreeMem (controls, sizeof (TMixerControlW) * MixLine.cControls);
   end
 else
 Result:=true
;
end
;

begin

  Result:=false
; MixerStart:=nil
; PMix:=nil
;
  if
 mixerGetNumDevs=0 then
 begin

    exit;
  end
 else
 begin

    MixerGetDevCaps (MixerDeviceID, @caps, sizeof (caps));
    err:= mixerOpen (@MixerHandle, MixerDeviceID, MixerCallbackHandle, 0, CALLBACK_WINDOW OR
 MIXER_OBJECTF_MIXER);
    if
 err = MMSYSERR_NOERROR then
 begin

      UpdateLinkedList(0,MixerStart,dword(-1),dword(-2),StrPas(caps.szPname),0,Data,false
,false
);
      PMix:=MixerStart;
        for
 j := 0 to
 caps.cDestinations - 1 do
 begin

          lineInfo.cbStruct := sizeof (lineInfo);
          lineInfo.dwDestination := j;
          lineinfo.dwSource:=0;           { Added this line 990318/HBn }
          Result:=false
;
          err:=mixerGetLineInfo (MixerHandle, @lineInfo, MIXER_GETLINEINFOF_DESTINATION);
          if
 err = MMSYSERR_NOERROR then
 begin

            speakers:=(lineInfo.dwComponentType=MIXERLINE_COMPONENTTYPE_DST_SPEAKERS);
            GetControl(PMix,lineInfo,speakers);
            for
 k := 0 to
 lineInfo.cConnections - 1 do
 begin

              connectionInfo.cbStruct := sizeof (connectionInfo);
              connectionInfo.dwDestination := j;
              connectionInfo.dwSource := k;
              Result:=false
;
              err:=mixerGetLineInfo (MixerHandle, @connectionInfo, MIXER_GETLINEINFOF_SOURCE);
              if
 err = MMSYSERR_NOERROR then
 GetControl(PMix,connectionInfo,speakers)
              else
 exit;
            end
;
            Result:=true
;
          end
 else
 exit;
        end
;
    end
;
  end
;
end
;
{$ENDIF}

{------------- Public methods ---------------------------------------}
constructor
 TAudio.Create(AOwner: TComponent);
begin

   inherited
 Create(AOwner);
   FDeviceID:=DefaultAudioDeviceID;
   FSepCtrl:=false
;
   FVersion:=Ver;
   FRecorder:=TRecorder.Create; FRecorder.FAudio:=Self;
   FRecorder.Active:=false
;
   FRecorder.FBPS:=BPSDefault;
   FRecorder.FNoSamples:=NoSamplesDefault;
   FRecorder.FChannels:=ChannelsDefault;
   FRecorder.FSPS:=SPSDefault;
   FRecorder.AddNextInBufferHandle:= AllocateHWnd(FRecorder.AddNextInBuffer2);
   FPlayer:=TPlayer.Create; FPlayer.FAudio:=Self;
   FPlayer.Active:=false
;
   FPlayer.FBPS:=BPSDefault;
   FPlayer.FNoSamples:=NoSamplesDefault;
   FPlayer.FChannels:=ChannelsDefault;
   FPlayer.FSPS:=SPSDefault;
   FPlayer.PlayStream:=nil
;
   FPlayer.FPlayFile:=false
;
   FPlayer.ActiveBuffers:=0;
   FPlayer.AddNextOutBufferHandle:= AllocateHWnd(FPlayer.AddNextOutBuffer2);
   FPlayer.CloseHandle:=AllocateHWnd(FPlayer.Close2);
   FWindowHandle:=AllocateHWnd(AudioCallBack);
{$IFDEF WIN32}
   WaveFmtSize:=SizeOf(TWaveFormatEx);
   Mixer:=TMixerSettings.Create;
   Mixer.MixerReady:=false
;
   Mixer.FAudio:=Self;
   FMixerDeviceID:=DefaultMixerDeviceID;
   Mixer.FList:=TStringList.Create;
   Mixer.MixerStart:=nil
;
   Mixer.MixerCallbackHandle:=AllocateHWnd(Mixer.MixerCallback);
   if
 Mixer.GetMixerSettings(FMixerDeviceID) then
 Mixer.MixerReady:=true
;
{$ELSE}
   WaveFmtSize:=SizeOf(TPCMWaveFormat);
{$ENDIF}
   FRecorder.RecToFile:=false
; ErrorMessage:='';
   if
 (waveInGetNumDevs<1) then
 Exit;
   if
 not
(FRecorder.AllocateMemory) then
 Exit;
   if
 (waveOutGetNumDevs<1) then
 Exit;
   if
 not
(FPlayer.AllocateMemory) then
 Exit;
end
;

destructor
 TAudio.Destroy;
var
 i:longint;
{$IFDEF WIN32}
    P1,P2 :PMixDetails;
{$ENDIF}
begin

   FPlayer.Stop;
   FRecorder.Stop;
{$IFDEF WIN32}
   Mixer.FList.Free;
   if
 Mixer.MixerStart<>nil
 then
 mixerClose(Mixer.MixerHandle);
   P1:=Mixer.MixerStart;
   while
 P1<>nil
 do
 begin

     P2:=P1.Next;
     Dispose(P1);
     P1:=P2;
   end
;
  if
 Mixer.MixerCallbackHandle<>0 then
 DeAllocateHwnd(Mixer.MixerCallbackHandle);
  Mixer.Free;
{$ENDIF}
  with
 FRecorder do
 begin

   if
 RecToFile and
 (RecStream<>nil
) then
 begin

     i:=RecStream.Size-8;    { size of file  }
     RecStream.Position:=4;
     RecStream.write(i,4);
     i:=i-$24;               { size of data  }
     RecStream.Position:=40;
     RecStream.write(i,4);
     RecStream.Free;
     RecToFile:=false
;
   end
;
 {  Close;       }
   FreeMemory;
   if
 AddNextInBufferHandle<>0 then
 DeallocateHWnd(AddNextInBufferHandle);
   Free;
  end
;
  with
 FPlayer do
 begin

    FreeMemory;
    if
 AddNextOutBufferHandle<>0 then
 DeallocateHWnd(AddNextOutBufferHandle);
    if
 CloseHandle<>0 then
 DeallocateHWnd(CloseHandle);
    Free;
  end
;
  if
 FWindowHandle<>0 then
 DeAllocateHWnd(FWindowHandle);
  inherited
 Destroy;
end
;

function
 TAudio.Query(var
 Product,Formats:string
):boolean;
var
 Caps : PWaveOutCaps;
    i1,i2,j1,j2 : Word;
    iErr : Integer;
begin

  Result:=false
;
  Product:=''; Formats:='';
  if
 (waveInGetNumDevs<=FDeviceID) or
 (waveOutGetNumDevs<=FDeviceID) then
 begin

    ErrorMessage:='No waveform device available';
    Exit;
  end
 else
 begin

    GetMem(Caps,SizeOf(TWaveOutCapsW));
    iErr:=waveOutGetDevCaps(FDeviceID,Caps,SizeOf(TWaveOutCaps));
    if
 (iErr<>0) then
 begin

      FPlayer.GetError(iErr,'');
      Exit;
    end
 else
 begin

      Product:=StrPas(Caps^.szPname);
      Formats:='';
      if
 ((Caps^.dwFormats and
 WAVE_FORMAT_1M08)>0) then
 Formats:='11.025';
      if
 ((Caps^.dwFormats and
 WAVE_FORMAT_2M08)>0) then
 Formats:=Formats+'/22.05';
      if
 ((Caps^.dwFormats and
 WAVE_FORMAT_1M08)>0) then
 Formats:=Formats+'/44.1';
      Formats:=Formats+' kHz, ';
      if
 ((Caps^.dwFormats and
 WAVE_FORMAT_1M08)>0) then
 Formats:=Formats+'Mono';
      if
 ((Caps^.dwFormats and
 WAVE_FORMAT_1S08)>0) then
 Formats:=Formats+'/Stereo';
      if
 ((Caps^.dwFormats and
 WAVE_FORMAT_1M08)>0) then
 Formats:=Formats+', 8';
      if
 ((Caps^.dwFormats and
 WAVE_FORMAT_1M16)>0) then
 Formats:=Formats+'/16';
      Formats:=Formats+'-bit, Playback Controls: ';
      if
 ((Caps^.dwSupport and
 WAVECAPS_LRVOLUME)>0) then
 Formats:=Formats+'Separate L/R Volume'
      else
 if
 ((Caps^.dwSupport and
 WAVECAPS_VOLUME)>0) then
 Formats:=Formats+'Volume';
      FPlayer.GetVolume(i1,i2);
      FPlayer.SetVolume((i1+10) mod
 65535,(i2+10) mod
 65535);
      FPlayer.GetVolume(j1,j2);
      FPlayer.SetVolume(i1,i2);
      if
 not
((j1=((i1+10) mod
 65535)) and
 (j2=((i2+10) mod
 65535))) then

        Formats:=Formats+' (not controllable with this DeviceID driver)';
      if
 ((Caps^.dwSupport and
 WAVECAPS_PITCH)>0) then
 Formats:=Formats+', Pitch';
      if
 ((Caps^.dwSupport and
 WAVECAPS_PLAYBACKRATE)>0) then
 Formats:=Formats+', Rate';
      if
 ((Caps^.dwSupport and
 WAVECAPS_SYNC)>0) then
 Formats:=Formats+', Synchronous Device';
      FRecorder.FPause:=true
;
      FRecorder.Close;
      if
 (FPlayer.Open and
 FRecorder.Open) then
 begin

        if
 (FPlayer.DeviceOpen and
 FRecorder.DeviceOpen) then
 Formats:='Full-duplex support, '+Formats
        else
 Formats:='Half-duplex support, '+Formats;
      end
 else
 Formats:='Half-duplex support, '+Formats;
      FRecorder.Close;
      FRecorder.FPause:=false
;
      PostMessage(FPlayer.CloseHandle,mm_wom_CLOSE,0,0);
     end
;
    if
 Caps<>nil
 then
 FreeMem(Caps,SizeOf(TWaveOutCapsW));
  end
;
  Result:=true
;
end
;

{ Callback routine used for CALLBACK_FUNCTION in waveInOpen    }
{$IFDEF WIN32}
procedure
 RecorderCallBack(hW:HWAVEIN; uMsg,dwInstance,dwParam1,dwParam2 : DWORD);  stdcall
;
{$ELSE}
procedure
 RecorderCallBack(hW:HWAVEIN; uMsg,dwInstance,dwParam1,dwParam2 : LongInt);  stdcall
;
{$ENDIF}
var
 LP,RP:pointer;
    Size:Word;
    RecPtr : PRecorder;
begin

  RecPtr := Pointer(dwInstance);
  with
 RecPtr^ do
 begin

   case
 uMsg of

    wim_OPEN  : Active:=true
;
    wim_CLOSE : Active:=false
;
    wim_DATA  : begin

                  if
 Active then
 begin

                    LP:=pWaveBuffer[ReturnIndex Mod
 No_Buffers];
                    RP:=pExtraBuffer[ReturnIndex Mod
 No_Buffers];
                    Size:=pWaveHeader[ReturnIndex Mod
 No_Buffers]^.dwBytesRecorded;
                    if
 (not
(FPause) and
 TestTrigger(LP,Size)) then
 begin

                           if
 RecToFile then
 RecStream.write(LP^,Size);
                           if
 Assigned(FAudio.FOnAudioRecord) then
 begin

                             if
 FSplit then
 begin

                               Split(LP,RP,Size);
                               FAudio.FOnAudioRecord(RecPtr^,LP,RP,Size);
                             end
 else
 FAudio.FOnAudioRecord(RecPtr^,LP,nil
,Size);
                           end
;
                    end
;
                    if
 (Size>0) then
 begin

                         PostMessage(AddNextInBufferHandle,wim_DATA,0,0);
                         ReturnIndex:=(ReturnIndex+1) mod
 No_Buffers;
                    end
;
                  end
;
                end
;
   end
;
  end
;
end
;

function
 TRecorder.Open : boolean;
var

  iErr, i : Integer;
begin

  if
 not
(DeviceOpen) then
 begin

    Result:=false
;
    ForwardIndex:=0;
    ReturnIndex:=0;
{$IFDEF WIN32}
   iErr:=waveInOpen(@WaveIn,FAudio.FDeviceID, pWaveFmt,dword(@RecorderCallBack),
                     dword(@FAudio.FRecorder), CALLBACK_FUNCTION+WAVE_ALLOWSYNC);
{  iErr:=waveInOpen(@WaveIn,FAudio.FDeviceID, pWaveFmt,FAudio.FWindowHandle,0, CALLBACK_WINDOW+WAVE_ALLOWSYNC); }
{$ELSE}
{  iErr:=waveInOpen(@WaveIn,FAudio.FDeviceID, @pWaveFmt^.wf,LongInt(@RecorderCallBack),
                    LongInt(@FAudio.FRecorder), CALLBACK_FUNCTION+WAVE_ALLOWSYNC);    }
{ Problem to get CALLBACK_FUNCTION to work in 16bit version    }
    iErr:=waveInOpen(@WaveIn,FAudio.FDeviceID, @pWaveFmt^.wf,FAudio.FWindowHandle,0, CALLBACK_WINDOW+WAVE_ALLOWSYNC);
{$ENDIF}
    if
 (iErr<>0) then
 begin

      Close;
      GetError(iErr,'Could not open the input device for recording: ');
      Exit;
    end
;
    DeviceOpen:=true
;
    InitWaveHeaders;
    for
 i:=0 to
 No_Buffers-1 do
 begin

     iErr:=waveInPrepareHeader(WaveIn, pWaveHeader[i], sizeof(TWAVEHDR));
       if
 (iErr<>0) then
 begin

           Close;
           GetError(iErr,'Error preparing header for recording: ');
           Exit;
       end
;
    end
;
    if
 not
(AddNextInBuffer) then
 begin

      FAudio.ErrorMessage:='Error adding next input buffer';
      Exit;
    end
;
  end
;
  Result:=true
;
end
;

function
 TRecorder.Close : boolean;
var

  iErr,i : Integer;
begin

  Result:=false
;
  if
 not
(DeviceOpen) then
 begin

     FAudio.ErrorMessage:='Recorder already closed';
     Result:=true
;
     Exit;
  end
;
  if
 (waveInReset(WaveIn)<>0) then
 begin

     FAudio.ErrorMessage:='Error in waveInReset';
     Exit;
  end
;
  for
 i:=0 to
 No_Buffers-1 do
 begin

     iErr:=waveInUnprepareHeader(WaveIn, pWaveHeader[i], sizeof(TWAVEHDR));
     if
 (iErr<>0) then
 begin

       GetError(iErr,'Error in waveInUnprepareHeader');
       Exit;
     end
;
  end
;
{$IFDEF WIN32}
  if
 (waveInClose(WaveIn)<>0) then
 begin

{$ELSE}
  if
 (correctedwaveInClose(WaveIn)<>0) then
 begin

{$ENDIF}
     FAudio.ErrorMessage:='Error closing input device';
     Exit;
  end
;
  DeviceOpen:=false
;
  Result:=true
;
end
;

function
 TRecorder.Start : boolean;
var

  iErr, i : Integer;
begin

  Result:=false
;
  if
 Open then
 begin

    iErr:=WaveInStart(WaveIn);
    if
 (iErr<>0) then
 begin

      GetError(iErr,'Error starting wave record: ');
      Close;
      Result:=false
;
      Exit;
    end
;
    for
 i:=1 to
 No_Buffers-1 do

      if
 not
(AddNextInBuffer) then
 begin

         FAudio.ErrorMessage:='Error adding next input buffer';
         Exit;
      end
;
    Result:=true
;
  end
;
end
;

function
 TRecorder.Stop : boolean;
var
 i:longint;
begin

  Active:=false
;
  Result:=Close;
  if
 RecToFile then
 begin

    i:=RecStream.Size-8;    { size of file  }
    RecStream.Position:=4;
    RecStream.write(i,4);
    i:=i-$24;               { size of data   }
    RecStream.Position:=40;
    RecStream.write(i,4);
    RecStream.Free;
    RecToFile:=false
;
  end
;
  while
 Active do
 Application.ProcessMessages;
end
;

procedure
 TRecorder.Pause;
begin

  if
 DeviceOpen then
 FPause:=true
;
end
;

procedure
 TRecorder.Restart;
begin

  if
 DeviceOpen then
 FPause:=false
;
end
;

procedure
 TRecorder.RecordToFile(FileName:string
; LP,RP:TStream);
var
 temp:string
;
    i : LongInt;
    T1,T2 : ^byte;
begin

  if
 FileName<>'' then
 begin

    RecToFile:=true
;
    RecStream:=TFileStream.Create(FileName,fmCreate);
    temp:='RIFF';RecStream.write(temp[1],length(temp));
    temp:=#0#0#0#0;RecStream.write(temp[1],length(temp));     { File size: to be updated }
    temp:='WAVE';RecStream.write(temp[1],length(temp));
    temp:='fmt ';RecStream.write(temp[1],length(temp));
    temp:=#$10#0#0#0;RecStream.write(temp[1],length(temp));   { Fixed }
    temp:=#1#0;RecStream.write(temp[1],length(temp));         { PCM format }
    if
 FChannels=Mono then
 temp:=#1#0
    else
 temp:=#2#0;
    RecStream.write(temp[1],length(temp));
    RecStream.write(FSPS,2);
    temp:=#0#0;RecStream.write(temp[1],length(temp));         { SampleRate is given is dWord }
{$IFDEF WIN32}
    with
 pWaveFmt^ do
 begin

{$ELSE}
    with
 pWaveFmt^.wf do
 begin

{$ENDIF}
      RecStream.write(nAvgBytesPerSec,4);
      RecStream.write(nBlockAlign,2);
    end
;
    RecStream.write(pWaveFmt^.wBitsPerSample,2);
    temp:='data';RecStream.write(temp[1],length(temp));
    temp:=#0#0#0#0;RecStream.write(temp[1],length(temp));    { Data size: to be updated }

    if
 (LP<>nil
) then
 begin

      LP.Position:=0;
      if
 (RP<>nil
) and
 (RP.Size=LP.Size) then
 begin

      RP.Position:=0;
      GetMem(T1,1000); T2:=T1;
      if
 FBPS=_8 then
 begin

        for
 i:=1 to
 LP.Size do
 begin

          LP.Read
(T2^,1);inc(T2,1);
          RP.Read
(T2^,1); inc(T2,1);
          if
 (i mod
 500)=0 then
 begin

            RecStream.Write(T1^,1000);
            T2:=T1;
          end
;
        end
;
        i:=LP.Size mod
 500;
        if
 i>0 then
 begin

          RecStream.Write(T1^,i*2);
        end
;
      end
 else
 begin

        for
 i:=1 to
 (LP.Size div
 2) do
 begin

          LP.Read
(T2^,2);inc(T2,2);
          RP.Read
(T2^,2); inc(T2,2);
          if
 (i mod
 250)=0 then
 begin

            RecStream.Write(T1^,1000);
            T2:=T1;
          end
;
        end
;
        i:=(LP.Size div
 2) mod
 250;
        if
 i>0 then
 begin

          RecStream.Write(T1^,i*2);
        end
;
      end
;
      FreeMem(T1,1000);
    end
 else
 RecStream.CopyFrom(LP,LP.Size);
{
    if (LP<>nil) then begin
      LP.Position:=0;
      if (RP<>nil) and (RP.Size=LP.Size) then begin
        RP.Position:=0;
        if FBPS=_8 then begin
          for i:=1 to LP.Size do begin
             RecStream.CopyFrom(LP,1);
             RecStream.CopyFrom(RP,1);
          end;
        end else begin
          for i:=1 to (LP.Size div 2) do begin
             RecStream.CopyFrom(LP,2);
             RecStream.CopyFrom(RP,2);
          end;
        end;
      end else RecStream.CopyFrom(LP,LP.Size);
}
      i:=RecStream.Size-8;    { size of file  }
      RecStream.Position:=4;
      RecStream.write(i,4);
      i:=i-$24;               { size of data   }
      RecStream.Position:=40;
      RecStream.write(i,4);
      RecStream.Free;
      RecToFile:=false
;
    end
;
  end
 else
 RecToFile:=false
;
end
;

{ Callback routine used for CALLBACK_FUNCTION in waveOutOpen   }
{$IFDEF WIN32}
procedure
 PlayerCallBack(hW:HWAVEOUT; uMsg,dwInstance,dwParam1,dwParam2 : DWORD);  stdcall
;
{$ELSE}
procedure
 PlayerCallBack(hW:HWAVEOUT; uMsg,dwInstance,dwParam1,dwParam2 : LongInt);  stdcall
;
{$ENDIF}
var
 PlayPtr : PPlayer;
begin

  PlayPtr := Pointer(dwInstance);
  with
 PlayPtr^ do
 begin

   case
 uMsg of

    wom_OPEN  : Active:=true
;
    wom_CLOSE : Active:=false
;
    wom_DONE  : if
 Active then
 begin

                  if
 (ForwardIndex=ReturnIndex) then
 begin

                    if
 not
(FinishedPlaying) then
 begin

                      FinishedPlaying:=true
;
Другое по теме:
Как воспроизвести wav-файл из ресурса (в EXE)
Работа с микрофоном
Изменение громкости