Delphi控件源码

开发平台：
Delphi

MMDSCptr.pas：源码内容
							{========================================================================}
{=                (c) 1995-98 SwiftSoft Ronald Dittrich                 =}
{========================================================================}
{=                          All Rights Reserved                         =}
{========================================================================}
{=  D 01099 Dresden             = Fax.: +49 (0)351-8037944              =}
{=  Loewenstr.7a                = info@swiftsoft.de                     =}
{========================================================================}
{=  Actual versions on http://www.swiftsoft.de/mmtools.html             =}
{========================================================================}
{=  This code is for reference purposes only and may not be copied or   =}
{=  distributed in any format electronic or otherwise except one copy   =}
{=  for backup purposes.                                                =}
{=                                                                      =}
{=  No Delphi Component Kit or Component individually or in a collection=}
{=  subclassed or otherwise from the code in this unit, or associated   =}
{=  .pas, .dfm, .dcu, .asm or .obj files may be sold or distributed     =}
{=  without express permission from SwiftSoft.                          =}
{=                                                                      =}
{=  For more licence informations please refer to the associated        =}
{=  HelpFile.                                                           =}
{========================================================================}
{=  $Date: 04.09.98 - 22:15:16 $                                        =}
{========================================================================}
unit MMDSCptr;
{$I COMPILER.INC}
{.$DEFINE _MMDEBUG}
interface
uses
  Windows,
  SysUtils,
  Messages,
  Classes,
  Controls,
  Dialogs,
  MMSystem,
  MMRegs,        { Should be after MMSystem }
  MMUtils,
  MMObj,
  MMDSPObj,
  MMOLE2,
  MMDSound,
  MMD3DTyp,
  MM3D,
  MMWave,
  MMPCMSup,
  MMACMDlg,
  MMWaveIO,
  MMDSMix
  {$IFDEF _MMDEBUG}
  ,MMDebug
  {$ENDIF}
  ;
const
  NOTIFICATIONTHREAD_TIMEOUT = INFINITE;
type
  EMMDSCaptureError = class(Exception);
  TMMDSCapture = class;
  TMMDSCaptureBuffer = class;
  {----------------------------------------------------------------------------}
  TMMDSCaptureBufferNotifyThread = class(TMMThreadEx)
  private
    FBuffer          : TMMDSCaptureBuffer;
    FSystemEvent,
    FBufferStopEvent : THandle;
    FSyncing         : Boolean;
    procedure DoBufferStop;
  protected
    procedure Execute; override;
  public
    constructor Create(ABuffer: TMMDSCaptureBuffer);
    destructor Destroy; override;
  end;
  {----------------------------------------------------------------------------}
  TMMDSCaptureBuffer = class(TMMObject)
  private
    FOwned           : Boolean;
    FCaptureBuffer   : IDirectSoundCaptureBuffer;
    FNotify          : IDirectSoundNotify;
    FCapture         : TMMDSCapture;
    FNotifyThread    : TMMDSCaptureBufferNotifyThread;
    FName            : string;
    FMemory          : TMemoryStream;
    FBufferLength    : Longint;
    FFormat          : PWaveFormatEx;
    FResetPosition   : Boolean;
    FCapturing       : Boolean;
    FBufferStopEvent : THandle;
    FOnBufferStop,
    FOnRelease       : TNotifyEvent;
    FCBOrigin,                      // Origin of capture buffer in the whole stream
    FCBSize,                        // buffer size
    FCBDataPosition  : Integer;     // bytes processed
    function  GetPosition: Longint;
    function  GetReadPosition: Longint;
    function  GetCapturing: Boolean;
    function  GetCaptureLength: Longint;
    procedure SetFormat(Value: PWaveFormatEx);
    function  GetCaps: TDSCBCAPS;
    procedure SetCaptureBuffer(Value: IDirectSoundCaptureBuffer);
    function  IsThereNewData: Boolean;
  protected
    procedure Capture;
    procedure Stop;
    procedure ReleaseBuffer;
    procedure FreeBuffer;
    procedure CopyData;
    property  DirectSoundCaptureBuffer: IDirectSoundCaptureBuffer read FCaptureBuffer write SetCaptureBuffer;
    property  DirectSoundNotify: IDirectSoundNotify read FNotify;
  public
    constructor Create(Size: Longint; Format: PWaveFormatEx); virtual;
    destructor  Destroy; override;
    property OnBufferStop: TNotifyEvent read FOnBufferStop write FOnBufferStop;
    property OnRelease: TNotifyEvent read FOnRelease write FOnRelease;
    property Caps: TDSCBCAPS read GetCaps;
    property Name: string read FName;
    property Memory: TMemoryStream read FMemory;
    property PWaveFormat: PWaveFormatEx read FFormat write SetFormat;
    property BufferLength: Longint read FBufferLength write FBufferLength;
    property CaptureLength: Longint read GetCaptureLength;
    property Capturing: Boolean read GetCapturing;
    property Position: Longint read GetPosition;
    property ResetPosition: Boolean read FResetPosition write FResetPosition;
  end;
  {----------------------------------------------------------------------------}
  TMMDSCaptureCaps = class(TMMObject)
  private
    FChannels: Integer;
    FFormats : Integer;
    function  GetHasFormat(Index: Integer): Boolean;
    procedure SetHasFormat(Index: Integer; Value: Boolean);
    procedure SetIntDummy(Value: Integer);
  protected
    procedure SetCaps(const Caps: TDSCCAPS);
  public
    property Formats: Integer read FFormats;
  published
    property Channels: Integer read FChannels write SetIntDummy;
    property Has11025Mono8bit: Boolean index 0 read GetHasFormat write SetHasFormat;
    property Has11025Mono16bit: Boolean index 1 read GetHasFormat write SetHasFormat;
    property Has11025Stereo8bit: Boolean index 2 read GetHasFormat write SetHasFormat;
    property Has11025Stereo16bit: Boolean index 3 read GetHasFormat write SetHasFormat;
    property Has22050Mono8bit: Boolean index 4 read GetHasFormat write SetHasFormat;
    property Has22050Mono16bit: Boolean index 5 read GetHasFormat write SetHasFormat;
    property Has22050Stereo8bit: Boolean index 6 read GetHasFormat write SetHasFormat;
    property Has22050Stereo16bit: Boolean index 7 read GetHasFormat write SetHasFormat;
    property Has44100Mono8bit: Boolean index 8 read GetHasFormat write SetHasFormat;
    property Has44100Mono16bit: Boolean index 9 read GetHasFormat write SetHasFormat;
    property Has44100Stereo8bit: Boolean index 10 read GetHasFormat write SetHasFormat;
    property Has44100Stereo16bit: Boolean index 11 read GetHasFormat write SetHasFormat;
  end;
  TMMDSBufferEvent = procedure(Sender: TObject; Buffer: TMMDSCaptureBuffer) of object;
  {----------------------------------------------------------------------------}
  TMMDSCapture = class(TMMNonVisualComponent)
  private
    DirectCapture   : IDirectSoundCapture;
    FDevices        : TList;
    FDeviceID       : TMMDeviceID;
    FProductName    : String;
    FBuffers        : TList;
    FCaps           : TMMDSCaptureCaps;
    FOnBufferStop   : TMMDSBufferEvent;
    procedure SetCaps(Value: TMMDSCaptureCaps);
    function  GetCaps: TMMDSCaptureCaps;
    function  GetNumDevs: integer;
    function  GetDevices(Index: integer): PDSDRIVERDESC;
    procedure SetDeviceID(DeviceID: TMMDeviceID);
    procedure SetProductName(const Value: String);
    function  GetBuffer(Index: integer): TMMDSCaptureBuffer;
    function  GetBufferName(const Name: string): TMMDSCaptureBuffer;
    function  GetBufferCount: integer;
    procedure SetupBuffer(var Name: string; Buffer: TMMDSCaptureBuffer);
    procedure ClearBuffer(Buffer: TMMDSCaptureBuffer);
    function  FindFreeName(const Name: String): String;
    function  GetOpened: Boolean;
  protected
    procedure BufferStop(Buffer: TMMDSCaptureBuffer); dynamic;
  public
    constructor Create(AOwner: TComponent); override;
    destructor  Destroy; override;
    procedure Open;
    procedure Close;
    function  AddBuffer(var Name: string; BufferLength: Longint; Format: PWaveFormatEx): TMMDSCaptureBuffer;
    procedure RemoveBuffer(Buffer: TMMDSCaptureBuffer);
    procedure CaptureBuffer(Buffer: TMMDSCaptureBuffer);
    procedure StopBuffer(Buffer: TMMDSCaptureBuffer);
    procedure UpdateData(Buffer: TMMDSCaptureBuffer);
    procedure FreeBuffers;
    property  Buffer[Index: integer]: TMMDSCaptureBuffer read GetBuffer;
    property  BufferByName[const Name: string]: TMMDSCaptureBuffer read GetBufferName;
    property  BufferCount: integer read GetBufferCount;
    property  NumDevs: integer read GetNumDevs;
    property  Devices[Index: integer]: PDSDRIVERDESC read GetDevices;
    property  Opened: Boolean read GetOpened;
  published
    property  OnBufferStop: TMMDSBufferEvent read FOnBufferStop write FOnBufferStop;
    property  CaptureCaps: TMMDSCaptureCaps read GetCaps write SetCaps;
    property  DeviceID: TMMDeviceID read FDeviceID write SetDeviceID default 0;
    property  ProductName: String read FProductName write SetProductName stored False;
  end;
  {----------------------------------------------------------------------------}
  TMMDSCaptureChannel = class(TMMDSPComponent)
  private
    FCaptureBuffer : TMMDSCaptureBuffer;
    FCapture       : TMMDSCapture;
    FOnCaptureStop : TNotifyEvent;
    function  GetInputFormat: string;
    procedure SetInputFormat(aValue: string);
    function  GetPosition: Longint;
    procedure SetReset(aValue: Boolean);
    function  GetReset: Boolean;
    function  GetCapturing: Boolean;
    function  GetBufferLength: Longint;
    procedure SetBufferLength(Value: Longint);
    function  GetCaptureLength: Longint;
    procedure BufferStop(Sender: TObject);
  protected
    procedure Notification(AComponent: TComponent; Operation: TOperation); override;
    procedure SetPWaveFormat(aValue: PWaveFormatEx); override;
    procedure DefineProperties(Filer: TFiler); override;
    procedure ReadData(Stream: TStream); virtual;
    procedure WriteData(Stream: TStream); virtual;
  public
    constructor Create(AOwner: TComponent); override;
    destructor  Destroy; override;
    procedure GetVUMeter(var LeftValue, RightValue, BothValue: integer; Interval: integer);
    procedure SaveFormatInRegistry(RootKey: HKEY; Localkey, Field: string);
    procedure LoadFormatFromRegistry(RootKey: HKEY; Localkey, Field: string);
    function  SelectFormat: Boolean;
    procedure SetPCMFormat(Mode: TMMMode; Bits: TMMBits; SampleRate: Longint);
    procedure Reset;
    procedure Init;
    procedure Capture;
    procedure Stop;
    function SaveToRAWFile(FName: TFileName): Boolean;
    function SaveToWaveFile(FName: TFileName): Boolean;
    property PWaveFormat;
    property CaptureBuffer: TMMDSCaptureBuffer read FCaptureBuffer;
    property Position: Longint read GetPosition;
    property CaptureLength: Longint read GetCaptureLength;
    property Capturing: Boolean read GetCapturing;
  published
    property OnCaptureStop: TNotifyEvent read FOnCaptureStop write FOnCaptureStop;
    property CaptureObject: TMMDSCapture read FCapture write FCapture;
    property BufferLength: Longint read GetBufferLength write SetBufferLength;
    property InputFormat: string read GetInputFormat write SetInputFormat stored False;
    property ResetPosition: Boolean read GetReset write SetReset default True;
  end;
implementation
{$IFDEF DELPHI3} resourcestring{$ELSE} const {$ENDIF}
  SLockFailed = 'DirectSoundCaptureBuffer Lock failed';
  SCannotConvertWave = 'Unable to convert sound data';
procedure DSCheckAvailable;
begin
  if _WinNT3_ then
    raise EMMDSCaptureError.Create(LoadResStr(IDS_DSNOTSUPPORTED));
  if not LoadDSoundDLL then
    raise EMMDSCaptureError.Create(LoadResStr(IDS_DLLERROR) + ' DSOUND.DLL...');
end;
{== TMMDSCapture ==============================================================}
constructor TMMDSCapture.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  DSCheckAvailable;
  FBuffers := TList.Create;
  FCaps := TMMDSCaptureCaps.Create;
  FDevices := TList.Create;
  if Assigned(DirectSoundCaptureEnumerate) then
     DirectSoundCaptureEnumerate(DriverEnumerate, FDevices);
  SetDeviceID(0);
  ErrorCode := ComponentRegistered(InitCode, Self, ClassName);
  if (ErrorCode <> 0) then RegisterFailed(InitCode, Self , ClassName);
end;
{-- TMMDSCapture --------------------------------------------------------------}
destructor TMMDSCapture.Destroy;
begin
  Close;
  FCaps.Free;
  FBuffers.Free;
  FreeDriverList(FDevices);
  FDevices.Free;
  inherited Destroy;
end;
{-- TMMDSCapture --------------------------------------------------------------}
procedure TMMDSCapture.BufferStop(Buffer: TMMDSCaptureBuffer);
begin
   UpdateData(Buffer);
   if Assigned(FOnBufferStop) then FOnBufferStop(Self, Buffer);
   if Assigned(Buffer.FOnBufferStop) then Buffer.FOnBufferStop(Buffer);
end;
{-- TMMDSCapture --------------------------------------------------------------}
function TMMDSCapture.GetDevices(Index: integer): PDSDRIVERDESC;
begin
  Result := PDSDRIVERDESC(FDevices.Items[Index])
end;
{-- TMMDSCapture --------------------------------------------------------------}
procedure TMMDSCapture.SetProductName(const Value: String);
begin
end;
{-- TMMDSCapture --------------------------------------------------------------}
function TMMDSCapture.GetNumDevs: integer;
begin
  Result := FDevices.Count;
end;
{-- TMMDSCapture --------------------------------------------------------------}
procedure TMMDSCapture.SetDeviceID(DeviceID: TMMDeviceID);
begin
  if (DirectCapture <> nil) then
    raise EMMDSCaptureError.Create(LoadResStr(IDS_PROPERTYOPEN));
  if (NumDevs > 0) and (DeviceID >= 0) and (DeviceID < NumDevs) then
  begin
    GetCaps;
    FProductName := Devices[DeviceID]^.Description;
    FDeviceID := DeviceID;
  end
  else
  begin
    FProductName := LoadResStr(IDS_DSNODEVICE);
    FDeviceID := InvalidID;
  end;
end;
{-- TMMDSCapture --------------------------------------------------------------}
procedure TMMDSCapture.Open;
begin
  if LoadDSoundDLL and (DirectCapture = nil) then
  begin
    if (DeviceID = InvalidID) then
      raise EMMDSCaptureError.Create(LoadResStr(IDS_INVALIDDEVICEID));
    try
      DSCheck(DirectSoundCaptureCreate(Devices[FDeviceID]^.lpGUID, DirectCapture, nil));
    except
      Close;
      raise;
    end;
  end;
end;
{-- TMMDSCapture --------------------------------------------------------------}
function TMMDSCapture.GetOpened: Boolean;
begin
  Result := DirectCapture <> nil;
end;
{-- TMMDSCapture --------------------------------------------------------------}
procedure TMMDSCapture.Close;
begin
  FreeBuffers;
  if (DirectCapture <> nil) then
  begin
    DirectCapture.Release;
    DirectCapture := nil;
  end;
end;
{-- TMMDSCapture --------------------------------------------------------------}
procedure TMMDSCapture.SetCaps(Value: TMMDSCaptureCaps);
begin
end;
{-- TMMDSCapture --------------------------------------------------------------}
function TMMDSCapture.GetCaps: TMMDSCaptureCaps;
var
  Caps: TDSCCAPS;
begin
  ZeroMemory(@Caps, SizeOf(Caps));
  Caps.dwSize := SizeOf(Caps);
  if (DeviceID <> InvalidID) then
  begin
    if not Opened then
    begin
      Open;
      try
        DirectCapture.GetCaps(Caps);
      finally
        Close;
      end;
    end
    else
      DirectCapture.GetCaps(Caps);
  end;
  FCaps.SetCaps(Caps);
  Result := FCaps;
end;
{-- TMMDSCapture --------------------------------------------------------------}
function TMMDSCapture.GetBuffer(Index: integer): TMMDSCaptureBuffer;
begin
  Result := TMMDSCaptureBuffer(FBuffers[Index])
end;
{-- TMMDSCapture --------------------------------------------------------------}
function TMMDSCapture.GetBufferName(const Name: string): TMMDSCaptureBuffer;
var
  i: integer;
begin
  for i := 0 to FBuffers.Count-1 do
  begin
    Result := FBuffers[i];
    if Result.Name = Name then
      exit;
  end;
  Result := nil;
end;
{-- TMMDSCapture --------------------------------------------------------------}
function TMMDSCapture.FindFreeName(const Name: String): String;
var
  i: integer;
begin
  if (BufferByName[Name] <> nil) or (Name = '') then
  begin
    i := 0;
    repeat
      Inc(i);
      Result := Name + IntToStr(i);
    until BufferByName[Result] = nil;
  end else
    Result := Name;
end;
{-- TMMDSCapture --------------------------------------------------------------}
function TMMDSCapture.GetBufferCount: integer;
begin
  Result := FBuffers.Count;
end;
{-- TMMDSCapture --------------------------------------------------------------}
procedure TMMDSCapture.SetupBuffer(var Name: string; Buffer: TMMDSCaptureBuffer);
var
  BufferDesc: TDSCBUFFERDESC;
  BufferInterface: IDirectSoundCaptureBuffer;
begin
  if (Buffer = nil) or (Buffer.PWaveFormat = nil) then exit;
  Name := FindFreeName(Name);
  Buffer.FName := Name;
  ZeroMemory(@BufferDesc, SizeOf(BufferDesc));
  with BufferDesc do
  begin
    dwSize := SizeOf(BufferDesc);
    dwFlags := 0;
    dwBufferBytes := Buffer.BufferLength;
    lpwfxFormat := Buffer.PWaveFormat;
   end;
  Buffer.DirectSoundCaptureBuffer := nil;
  DSCheck(DirectCapture.CreateCaptureBuffer(BufferDesc,BufferInterface, nil));
  Buffer.DirectSoundCaptureBuffer := BufferInterface;
  Buffer.FCapture := Self;
  FBuffers.Add(Buffer);
end;
{-- TMMDSCapture --------------------------------------------------------------}
function TMMDSCapture.AddBuffer(var Name: string; BufferLength: Longint; Format: PWaveFormatEx): TMMDSCaptureBuffer;
begin
  Result := TMMDSCaptureBuffer.Create(BufferLength, Format);
  try
    SetupBuffer(Name, Result);
  except
    Result.Free;
    raise;
  end;
end;
{-- TMMDSCapture --------------------------------------------------------------}
procedure TMMDSCapture.FreeBuffers;
begin
  while BufferCount > 0 do RemoveBuffer(Buffer[0]);
end;
{-- TMMDSCapture --------------------------------------------------------------}
procedure TMMDSCapture.ClearBuffer(Buffer: TMMDSCaptureBuffer);
var
  i: integer;
begin
  i := FBuffers.IndexOf(Buffer);
  if i >= 0 then
  begin
    StopBuffer(Buffer);
    Buffer.ReleaseBuffer;
    FBuffers.Delete(i);
    FBuffers.Pack;
  end;
end;
{-- TMMDSCapture --------------------------------------------------------------}
procedure TMMDSCapture.RemoveBuffer(Buffer: TMMDSCaptureBuffer);
begin
  ClearBuffer(Buffer);
  Buffer.FreeBuffer;
end;
{-- TMMDSCapture --------------------------------------------------------------}
procedure TMMDSCapture.CaptureBuffer(Buffer: TMMDSCaptureBuffer);
begin
  if (Buffer <> nil) and (Buffer.DirectSoundCaptureBuffer <> nil) then
      Buffer.Capture;
end;
{-- TMMDSCapture --------------------------------------------------------------}
procedure TMMDSCapture.StopBuffer(Buffer: TMMDSCaptureBuffer);
begin
  if (Buffer <> nil) and (Buffer.DirectSoundCaptureBuffer <> nil) then
      Buffer.Stop;
end;
{-- TMMDSCapture --------------------------------------------------------------}
procedure TMMDSCapture.UpdateData(Buffer: TMMDSCaptureBuffer);
begin
   Buffer.CopyData
end;
{== TMMDSCaptureCaps ==========================================================}
procedure TMMDSCaptureCaps.SetIntDummy(Value: Integer);
begin
end;
{-- TMMDSCaptureCaps ----------------------------------------------------------}
function TMMDSCaptureCaps.GetHasFormat(Index: Integer): Boolean;
begin
  Result := FFormats and (1 shl Index) <> 0
end;
{-- TMMDSCaptureCaps ----------------------------------------------------------}
procedure TMMDSCaptureCaps.SetHasFormat(Index: Integer; Value: Boolean);
begin
end;
{-- TMMDSCaptureCaps ----------------------------------------------------------}
procedure TMMDSCaptureCaps.SetCaps(const Caps: TDSCCAPS);
begin
  FFormats := Caps.dwFormats;
  FChannels := Caps.dwChannels;
end;
const
  LoopFlags: array[Boolean] of Integer = (0, DSCBSTART_LOOPING);
{== TMMDSCaptureBuffer ========================================================}
constructor TMMDSCaptureBuffer.Create(Size: Longint; Format: PWaveFormatEx);
begin
   inherited Create;
   FMemory := TMemoryStream.Create;
   FBufferLength := Size;
   FFormat       := wioCopyWaveFormat(Format);
   FResetPosition:= True;
end;
{-- TMMDSCaptureBuffer --------------------------------------------------------}
destructor TMMDSCaptureBuffer.Destroy;
begin
  ReleaseBuffer;
  FMemory.Free;
  GlobalFreeMem(Pointer(FFormat));
  inherited Destroy;
end;
{-- TMMDSCaptureBuffer --------------------------------------------------------}
procedure TMMDSCaptureBuffer.SetFormat(Value: PWaveFormatEx);
begin
   GlobalFreeMem(Pointer(FFormat));
   FFormat := wioCopyWaveFormat(Value);
end;
{-- TMMDSCaptureBuffer --------------------------------------------------------}
function TMMDSCaptureBuffer.GetCaptureLength: Longint;
begin
   Result := FMemory.Size
end;
{-- TMMDSCaptureBuffer --------------------------------------------------------}
procedure TMMDSCaptureBuffer.SetCaptureBuffer(Value: IDirectSoundCaptureBuffer);
var
  Caps: TDSCBCAPS;
  Positions: array[0..2] of TDSBPOSITIONNOTIFY;
begin
  ReleaseBuffer;
  FCaptureBuffer := Value;
  if Value <> nil then
  begin
    if FCaptureBuffer.QueryInterface(IID_IDirectSoundNotify, FNotify) = S_OK then
    begin
      ZeroMemory(@Caps, SizeOf(Caps));
      Caps.dwSize := SizeOf(Caps);
      FCaptureBuffer.GetCaps(Caps);
      FCBSize := Caps.dwBufferBytes;
      FBufferStopEvent := CreateEvent(nil, False, False, nil);
      Positions[0].dwOffset := DSBPN_OFFSETSTOP;
      Positions[0].hEventNotify := FBufferStopEvent;
      FNotify.SetNotificationPositions(1, @Positions);
      FNotifyThread := TMMDSCaptureBufferNotifyThread.Create(Self);
    end;
  end;
end;
{-- TMMDSCaptureBuffer --------------------------------------------------------}
function TMMDSCaptureBuffer.GetPosition: Longint;
var
   aResult: DWORD;
begin
  if (FCaptureBuffer <> nil) then
  begin
    FCaptureBuffer.GetCurrentPosition(aResult, DWORD(nil^));
    Result := aResult;
  end
  else
    Result := 0;
end;
{-- TMMDSCaptureBuffer --------------------------------------------------------}
function TMMDSCaptureBuffer.GetReadPosition: Longint;
var
   aResult: DWORD;
begin
  if (FCaptureBuffer <> nil) then
  begin
     FCaptureBuffer.GetCurrentPosition(DWORD(nil^), aResult);
     Result := aResult;
  end
  else Result := 0;
end;
{-- TMMDSCaptureBuffer --------------------------------------------------------}
function TMMDSCaptureBuffer.GetCapturing: Boolean;
var
  Status: DWORD;
begin
  if FCaptureBuffer <> nil then
  begin
    FCaptureBuffer.GetStatus(Status);
    Result := Status and DSCBSTATUS_CAPTURING <> 0;
  end
  else
    Result := False;
end;
{-- TMMDSCaptureBuffer --------------------------------------------------------}
function TMMDSCaptureBuffer.GetCaps: TDSCBCAPS;
begin
  ZeroMemory(@Result, SizeOf(Result));
  Result.dwSize := SizeOf(Result);
  if FCaptureBuffer <> nil then
     FCaptureBuffer.GetCaps(Result);
end;
{-- TMMDSCaptureBuffer --------------------------------------------------------}
procedure TMMDSCaptureBuffer.Capture;
begin
  if FCaptureBuffer <> nil then
  begin
    if not Capturing then
    begin
      FCBOrigin := 0;
      FCBDataPosition := GetPosition;
      if FResetPosition then Memory.Clear;
    end;
    FCaptureBuffer.Start(LoopFlags[False]);
    FCapturing := True;
  end;
end;
{-- TMMDSCaptureBuffer --------------------------------------------------------}
procedure TMMDSCaptureBuffer.Stop;
begin
  if FCaptureBuffer <> nil then
  begin
    FCapturing := False;
    FCaptureBuffer.Stop;
  end;
end;
{-- TMMDSCaptureBuffer --------------------------------------------------------}
procedure TMMDSCaptureBuffer.ReleaseBuffer;
begin
  if FCaptureBuffer <> nil then
  begin
    FCaptureBuffer.Release;
    FCaptureBuffer := nil;
    if Assigned(FNotify) then
    begin
      with FNotifyThread do
      begin
        Terminate;
        SetEvent(FSystemEvent);
        if FSyncing then FreeOnTerminate := True else Free;
      end;
      FNotifyThread := nil;
      FNotify.Release;
      FNotify := nil;
      CloseHandle(FBufferStopEvent);
      FBufferStopEvent := 0;
    end;
    if Assigned(FOnRelease) then
       FOnRelease(Self);
  end;
end;
{-- TMMDSCaptureBuffer --------------------------------------------------------}
procedure TMMDSCaptureBuffer.FreeBuffer;
begin
  ReleaseBuffer;
  if not FOwned then Free;
end;
{-- TMMDSCaptureBuffer --------------------------------------------------------}
function TMMDSCaptureBuffer.IsThereNewData: Boolean;
begin
  Result := FCBOrigin + GetPosition > FCBDataPosition
end;
{$DEFINE ACCUMULATE}
{-- TMMDSCaptureBuffer --------------------------------------------------------}
procedure TMMDSCaptureBuffer.CopyData;
var
  p1, p2: Pointer;
  l1, l2: DWORD;
  CaptureCursor,
{$IFDEF ACCUMULATE}
  bl2,
{$ENDIF}
  bp1, bl1: DWORD;
begin
  if not IsThereNewData then
    exit;
  DSCheck(FCaptureBuffer.GetCurrentPosition(DWORD(nil^), CaptureCursor));
  if FCBDataPosition < FCBOrigin then
  begin
    bp1 := FCBDataPosition - (FCBOrigin - FCBSize);
    bl1 := FCBSize - bp1;
{$IFDEF ACCUMULATE}
    bl2 := CaptureCursor;
{$ENDIF}
  end else
  begin
    bp1 := FCBDataPosition - FCBOrigin;
    bl1 := CaptureCursor - bp1;
{$IFDEF ACCUMULATE}
    bl2 := 0;
{$ENDIF}
  end;
{$IFDEF _MMDEBUG}
    DB_FormatLn(0, 'Locking capture buffer from %d to %d and %d to %d',
      [bp1, bp1 + bl1, 0, {$IFDEF ACCUMULATE}bl2{$ELSE}0{$ENDIF}]);
{$ENDIF}
  try
    with Memory do
{$IFDEF ACCUMULATE}
      Position := Size;
{$ELSE}
      if bp1 = 0 then Clear else Position := Size;
{$ENDIF}
    DSCheck(FCaptureBuffer.Lock(bp1, bl1, p1, l1, p2, l2, 0));
    Memory.Write(p1^, l1);
    if l2 > 0 then Memory.Write(p2^, l2);
    DSCheck(FCaptureBuffer.Unlock(p1, l1, p2, l2));
{$IFDEF ACCUMULATE}
    if bl2 > 0 then
    begin
       DSCheck(FCaptureBuffer.Lock(0, bl2, p1, l1, p2, l2, 0));
       Memory.Write(p1^, l1);
       if l2 > 0 then Memory.Write(p2^, l2);
       DSCheck(FCaptureBuffer.Unlock(p1, l1, p2, l2));
    end;
{$ENDIF}
{$IFDEF ACCUMULATE}
    Inc(FCBDataPosition, bl1 + bl2);
{$ELSE}
    Inc(FCBDataPosition, bl1);
{$ENDIF}
  except
    ReleaseBuffer;
    raise EMMDSCaptureError.Create(SLockFailed);
  end;
end;
{== TMMDSCaptureBufferNotifyThread ============================================}
constructor TMMDSCaptureBufferNotifyThread.Create(ABuffer: TMMDSCaptureBuffer);
begin
  inherited Create(False);
  FBuffer := ABuffer;
  FSystemEvent := CreateEvent(nil, False, False, nil);
end;
{-- TMMDSCaptureBufferNotifyThread --------------------------------------------}
destructor TMMDSCaptureBufferNotifyThread.Destroy;
begin
  CloseHandle(FSystemEvent);
  inherited;
end;
{-- TMMDSCaptureBufferNotifyThread --------------------------------------------}
procedure TMMDSCaptureBufferNotifyThread.Execute;
var
  HandleCount: Integer;
begin
  while not Terminated do
  begin
    if FBuffer.DirectSoundCaptureBuffer <> nil then
    begin
      FBufferStopEvent := FBuffer.FBufferStopEvent;
      HandleCount := 2;
    end
    else
      HandleCount := 1;
{$IFDEF _MMDEBUG}
    if HandleCount = 1
      then DB_FormatLn(0, 'Thread: Waiting for system event %d', [FSystemEvent])
      else DB_FormatLn(0, 'Thread: Waiting for system event %d and stop event %d', [FSystemEvent, FBufferStopEvent]);
{$ENDIF}
    case WaitForMultipleObjects(HandleCount, @FSystemEvent, False,
         NOTIFICATIONTHREAD_TIMEOUT) - WAIT_OBJECT_0 of
      0: {$IFDEF _MMDEBUG}
         DB_FormatLn(0, 'Thread: System event fired', [0])
         {$ENDIF}
         ;
      1: {$IFDEF _MMDEBUG}
         begin
           DB_FormatLn(0, 'Thread: Stop event, synchronizing...', [0]);
         {$ENDIF}
           Synchronize(DoBufferStop);
         {$IFDEF _MMDEBUG}
         end;
         {$ENDIF}
    end;
  end;
end;
{-- TMMDSCaptureBufferNotifyThread --------------------------------------------}
procedure TMMDSCaptureBufferNotifyThread.DoBufferStop;
begin
  FSyncing := True;
  try
     { detecting full loop by CursorPos }
    with FBuffer do
    if (GetPosition = 0) then Inc(FCBOrigin, FCBSize);
    if Assigned(FBuffer.FCapture) then
       FBuffer.FCapture.BufferStop(FBuffer);
  finally
    FSyncing := False;
  end;
end;
{== TMMDSCaptureChannel =======================================================}
constructor TMMDSCaptureChannel.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  DSCheckAvailable;
  FCaptureBuffer := TMMDSCaptureBuffer.Create(100000,nil);
  FCaptureBuffer.FOnBufferStop := BufferStop;
  FCaptureBuffer.FOwned := True;
  SetPCMFormat(mMono, b8Bit, 11025);
   ErrorCode := ComponentRegistered(InitCode, Self, ClassName);
   if (ErrorCode <> 0) then RegisterFailed(InitCode, Self , ClassName);
end;
{-- TMMDSCaptureChannel -------------------------------------------------------}
destructor TMMDSCaptureChannel.Destroy;
begin
  if FCapture <> nil then FCapture.Close;
  FCaptureBuffer.Free;
  inherited Destroy;
end;
{-- TMMDSCaptureChannel -------------------------------------------------------}
procedure TMMDSCaptureChannel.Notification(AComponent: TComponent; Operation: TOperation);
begin
  inherited Notification(AComponent, Operation);
  if (Operation = opRemove) and (AComponent = FCapture) then
    FCapture := Nil;
end;
{-- TMMDSCaptureChannel -------------------------------------------------------}
procedure TMMDSCaptureChannel.BufferStop(Sender: TObject);
begin
  if Assigned(FOnCaptureStop) then FOnCaptureStop(Self);
  if FCaptureBuffer.GetPosition = 0 then
     FCapture.RemoveBuffer(FCaptureBuffer);
end;
{-- TMMDSCaptureChannel -------------------------------------------------------}
procedure TMMDSCaptureChannel.Init;
var
  AName: string;
begin
  if (FCapture <> nil) and (BufferLength > 0) then
  with FCapture do
  begin
     if (FCaptureBuffer.DirectSoundCaptureBuffer = nil) then
     begin
        FCapture.Open;
        SetupBuffer(AName, FCaptureBuffer);
     end;
  end;
end;
{-- TMMDSCaptureChannel -------------------------------------------------------}
procedure TMMDSCaptureChannel.Reset;
begin
  if Assigned(FCaptureBuffer) then
     FCapture.RemoveBuffer(FCaptureBuffer);
end;
{-- TMMDSCaptureChannel -------------------------------------------------------}
procedure TMMDSCaptureChannel.Capture;
begin
  Init;
  if FCapture <> nil then
     FCapture.CaptureBuffer(FCaptureBuffer);
end;
{-- TMMDSCaptureChannel -------------------------------------------------------}
procedure TMMDSCaptureChannel.Stop;
begin
  if FCapture <> nil then
     FCapture.StopBuffer(FCaptureBuffer);
end;
{-- TMMDSCaptureChannel -------------------------------------------------------}
function TMMDSCaptureChannel.GetPosition: Longint;
begin
  Result := FCaptureBuffer.GetPosition
end;
{-- TMMDSCaptureChannel -------------------------------------------------------}
procedure TMMDSCaptureChannel.SetPWaveFormat(aValue: PWaveFormatEx);
begin
   FCaptureBuffer.PWaveFormat := aValue;
   inherited;
end;
{-- TMMDSCaptureChannel -------------------------------------------------------}
function TMMDSCaptureChannel.GetBufferLength: Longint;
begin
   Result := FCaptureBuffer.BufferLength;
end;
{-- TMMDSCaptureChannel -------------------------------------------------------}
procedure TMMDSCaptureChannel.SetBufferLength(Value: Longint);
begin
   FCaptureBuffer.BufferLength := Value;
end;
{-- TMMDSCaptureChannel -------------------------------------------------------}
function TMMDSCaptureChannel.GetCaptureLength: Longint;
begin
   Result := FCaptureBuffer.CaptureLength;
end;
{-- TMMDSCaptureChannel -------------------------------------------------------}
function TMMDSCaptureChannel.GetCapturing: Boolean;
begin
  Result := FCaptureBuffer.Capturing
end;
{-- TMMDSCaptureChannel -------------------------------------------------------}
procedure TMMDSCaptureChannel.SetReset(aValue: Boolean);
begin
   FCaptureBuffer.ResetPosition := aValue;
end;
{-- TMMDSCaptureChannel -------------------------------------------------------}
function TMMDSCaptureChannel.GetReset: Boolean;
begin
   Result := FCaptureBuffer.ResetPosition;
end;
{-- TMMDSCaptureChannel -------------------------------------------------------}
procedure TMMDSCaptureChannel.ReadData(Stream: TStream);
var
   Buf: PChar;
begin
   Buf := GlobalAllocMem(Stream.Size);
   try
      Stream.ReadBuffer(Buf^,Stream.Size);
      PWaveFormat := Pointer(Buf);
   finally
      GlobalFreeMem(Pointer(Buf));
   end;
end;
{-- TMMDSCaptureChannel -------------------------------------------------------}
procedure TMMDSCaptureChannel.WriteData(Stream: TStream);
begin
   if (PWaveFormat <> nil) then
       Stream.WriteBuffer(PWaveFormat^,wioSizeOfWaveFormat(PWaveFormat));
end;
{-- TMMDSCaptureChannel -------------------------------------------------------}
procedure TMMDSCaptureChannel.DefineProperties(Filer: TFiler);
begin
   inherited DefineProperties(Filer);
   Filer.DefineBinaryProperty('WaveFormatEx', ReadData, WriteData, PWaveFormat <> nil);
end;
{-- TMMDSCaptureChannel -------------------------------------------------------}
procedure TMMDSCaptureChannel.SetPCMFormat(Mode: TMMMode; Bits: TMMBits; SampleRate: Longint);
var
   wfx: TWaveFormatEx;
begin
   pcmBuildWaveHeader(@wfx, (Ord(Bits)+1)*8, Ord(Mode)+1, SampleRate);
   PWaveFormat := @wfx;
end;
{-- TMMDSCaptureChannel -------------------------------------------------------}
function TMMDSCaptureChannel.SelectFormat: Boolean;
var
   ACM: TMMACM;
begin
   ACM := TMMACM.Create(nil);
   try
      ACM.EnumFormats := efRestrict;
      Result := ACM.ChooseFormat(PWaveFormat,'Select Format');
      if Result then
         PWaveFormat := ACM.PWaveFormat;
   finally
      ACM.Free;
   end;
end;
{-- TMMDSCaptureChannel -------------------------------------------------------}
function TMMDSCaptureChannel.GetInputFormat: string;
var
   FormatTag, Format: string;
begin
   Result := 'Unknown';
   if (PWaveFormat <> nil) and
      acmGetFormatDescription(PWaveFormat, FormatTag, Format) then
      Result := FormatTag+' '+Format;
end;
{-- TMMDSCaptureChannel -------------------------------------------------------}
procedure TMMDSCaptureChannel.SetInputFormat(aValue: string);
begin
   MessageDlg('This is a read-only property, please use SelectFormat.',
              mtInformation,[mbOK],0);
end;
{-- TMMDSCaptureChannel -------------------------------------------------------}
procedure TMMDSCaptureChannel.SaveFormatInRegistry(RootKey: HKEY; Localkey, Field: string);
begin
   if (PWaveFormat <> nil) then
       SaveInRegistryBinary(RootKey,LocalKey,Field,PWaveFormat^,wioSizeOfWaveFormat(PWaveFormat));
end;
{-- TMMDSCaptureChannel -------------------------------------------------------}
procedure TMMDSCaptureChannel.LoadFormatFromRegistry(RootKey: HKEY; Localkey, Field: string);
var
   wfx: array[0..1024] of Char;
begin
   if GetFromRegistryBinary(RootKey,LocalKey,Field,wfx,sizeOf(wfx)) > 0 then
      PWaveFormat := @wfx;
end;
{-- TMMDSCaptureChannel -------------------------------------------------------}
function TMMDSCaptureChannel.SaveToRAWFile(FName: TFileName): Boolean;
begin
  Result := False;
  if (CaptureLength > 0) then
  try
     FCaptureBuffer.Memory.SaveToFile(FName);
     Result := True
  except
  end;
end;
{-- TMMDSCaptureChannel -------------------------------------------------------}
function TMMDSCaptureChannel.SaveToWaveFile(FName: TFileName): Boolean;
var
   lpwio: PWaveIOCB;
begin
   Result := False;
   if (CaptureLength > 0) then
   begin
      if (wioCreateFileInfo(lpwio, PWaveFormat) = 0) and (lpwio <> nil) then
      try
         if wioWriteFileInfo(lpwio, PChar(FName)) = 0 then
         try
            Result := wioWaveWriteData(lpwio, FCaptureBuffer.Memory.Memory, CaptureLength) = CaptureLength;
         finally
            wioWaveClose(lpwio);
         end;
      finally
         wioFreeFileInfo(lpwio);
      end;
   end;
end;
{-- TMMDSCaptureChannel -------------------------------------------------------}
procedure TMMDSCaptureChannel.GetVUMeter(var LeftValue, RightValue, BothValue: integer; Interval: integer);
var
   nBytes,dwPos: DWORD;
   PeakLeft,PeakRight: Smallint;
   wfx: TWaveFormatEx;
   p1,p2: Pointer;
   l1,l2: DWORD;
begin
   LeftValue  := 0;
   RightValue := 0;
   BothValue  := 0;
   if Capturing and (PWaveFormat^.wFormatTag = WAVE_FORMAT_PCM) then
   begin
      FCaptureBuffer.DirectSoundCaptureBuffer.GetFormat(@wfx, SizeOf(wfx), DWORD(nil^));
      nBytes := wioTimeToBytes(@wfx,Interval);
      dwPos := FCaptureBuffer.GetReadPosition;
      if (dwPos - nBytes > 0) then
      begin
         if FCaptureBuffer.DirectSoundCaptureBuffer.Lock(dwPos-nBytes,nBytes, p1, l1, p2, l2, 0) <> 0 then
            exit;
         if (l1 >= nBytes) then
         begin
            pcmFindPeak(@wfx,p1,nBytes, PeakLeft, PeakRight);
            if (wfx.wBitsPerSample = 8) then
            begin
               PeakLeft := (PeakLeft-128)*255;
               PeakRight:= (PeakRight-128)*255;
            end;
            LeftValue := abs(PeakLeft);
            RightValue := abs(PeakRight);
            BothValue := (LeftValue + RightValue) div 2;
         end;
         FCaptureBuffer.DirectSoundCaptureBuffer.Unlock(p1, l1, p2, l2);
      end;
   end;
end;
end.

						