mixing.pas

灰鸽子VIP1.2经典源代码

{*************************************************************************
  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, [e-mail]

  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 mixing;

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