Delphi控件源码

开发平台：
Delphi

MMDsCapt.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: 11.08.98 - 16:02:05 $                                        =}
{========================================================================}
unit MMDsCapt;
{$C FIXED PRELOAD PERMANENT}
{$I COMPILER.INC}
{.$DEFINE _MMDEBUG}
interface
uses
  Windows,
  Classes,
  SysUtils,
  MMObj,
  MMSystem,
  MMOLE2,
  MMUtils,
  MMRegs,
  MMWaveIO,
  MMPCMSup,
{$IFDEF _MMDEBUG}
  MMDebug,
{$ENDIF}
  MMDSound;
type
  EDSWaveIn = class(Exception)
  protected
    FCode: MMRESULT;
  public
    constructor Create(Code: MMRESULT);
  end;
function DSWaveInGetNumDevs: UINT; stdcall;
function DSWaveInGetDevCaps(HIn: HWaveIn; lpCaps: PWaveInCaps; uSize: UINT): MMRESULT; stdcall;
function DSWaveInGetErrorText(mmrError: MMRESULT; lpText: PChar; uSize: UINT): MMRESULT; stdcall;
function DSWaveInOpen(lpHWaveIn: PHWaveIn; uDeviceID: UINT; lpFormatEx: PWaveFormatEx; dwCallback, dwInstance, dwFlags: DWORD): MMRESULT; stdcall;
function DSWaveInClose(HIn: HWaveIn): MMRESULT; stdcall;
function DSWaveInPrepareHeader(HIn: HWaveIn; lpWaveInHdr: PWaveHdr; uSize: UINT): MMRESULT; stdcall;
function DSWaveInUnprepareHeader(HIn: HWaveIn; lpWaveInHdr: PWaveHdr; uSize: UINT): MMRESULT; stdcall;
function DSWaveInAddBuffer(HIn: HWaveIn; lpWaveInHdr: PWaveHdr; uSize: UINT): MMRESULT; stdcall;
function DSWaveInStart(HIn: HWaveIn): MMRESULT; stdcall;
function DSWaveInStop(HIn: HWaveIn): MMRESULT; stdcall;
function DSWaveInReset(HIn: HWaveIn): MMRESULT; stdcall;
function DSWaveInGetPosition(HIn: HWaveIn; lpInfo: PMMTime; uSize: UINT): MMRESULT; stdcall;
function DSWaveInGetID(HIn: HWaveIn; lpuDeviceID: PUINT): MMRESULT; stdcall;
function DSWaveInMessage(HIn: HWaveIn; uMessage: UINT; dw1, dw2: DWORD): MMRESULT; stdcall;
function DSWaveInGetIDirectSoundCapture(HIn: HWaveIn): IDirectSoundCapture;
implementation
const
  DEFAULT_BUFFERSIZE    = 2048 + 1024;
  DEFAULT_BUFFERCOUNT   = 4;
  NOTIFICATIONTHREAD_TIMEOUT = INFINITE;
type
  TDsNotificationThread = class(TMMThreadEx)
  protected
    FSystemEvent: THandle;
    procedure Execute; override;
  public
    constructor Create;
    destructor Destroy; override;
  end;
  TDsWaveInDevice = class;
  TDsWaveBuffer = class(TMMObject)
  private
    FData: PWaveHdr;
  protected
    function CanAccept: Integer;
    function Accept(WaveData: Pointer; var Length: Integer): Boolean;
  public
    constructor Create(lpWaveHdr: PWaveHdr);
    property Data: PWaveHdr read FData;
  end;
  TWaveDeviceState = (wdsInactive, wdsIdle, wdsStarted, wdsPaused);
  PNotifyPointArray = ^TNotifyPointArray;
  TNotifyPointArray = array[0..15] of TDSBPOSITIONNOTIFY;
  TDsWaveInDevice = class(TMMObject)
  private
    FCapture: IDirectSoundCapture;
    FGuid: PGUID;
    FWaveMapped: Boolean;
    FBuffer: IDirectSoundCaptureBuffer;
    FNotifications: IDirectSoundNotify;
    FNotifyPts: PNotifyPointArray;
    FState: TWaveDeviceState;
    FWaveBuffers,
    FQueue: TList;
    FBufferCount,                 // Count of buffer divisions
    FBufferPartSize,              // Each division size
    FBufferSize,                  // Multiplication of the previous two
    FBufferOrigin,                // Global origin of DX buffer
    FWritePosition: Integer;     // Global processed data position
    FCallBackMode,
    FCallBack,
    FCBInstance: Integer;
    function GetFormat: PWaveFormatEx;
    procedure SetFormat(Value: PWaveFormatEx);
    procedure ReturnBuffer;
    function CaptureActive: Boolean;
  protected
    procedure NotifyMessage(Msg: UINT; wParam: WPARAM; lParam: LPARAM); stdcall;
    procedure ProcessData(PointNumber: Integer);
    procedure Reconfigure(lpFormat: PWaveFormatEx; ABufCount, ABufSize: Integer);
  public
    constructor Create(DeviceGuid: PGUID; lpFormat: PWaveFormatEx);
    destructor Destroy; override;
    class procedure EnterCritical;
    class procedure LeaveCritical;
    procedure AddBuffer(Header: PWaveHdr);
    procedure PrepareBuffer(Header: PWaveHdr);
    procedure UnprepareBuffer(Header: PWaveHdr);
    function  FindBuffer(Header: PWaveHdr): TDsWaveBuffer;
    procedure Start;
    procedure Stop;
    procedure Reset;
    procedure GetPosition(lpInfo: PMMTime);
    procedure GetCaps(var Caps: TWaveInCaps);
    property Format: PWaveFormatEx read GetFormat write SetFormat;
  end;
var
  CaptureDeviceList: TList;
  OpenDevices: TList;
  DsNotificationThread: TDsNotificationThread;
  DsNotificationThread_RefCount: Integer = 0;
 // EDSWaveIn
constructor EDSWaveIn.Create(Code: MMRESULT);
var
  S: String;
begin
  SetLength(S, 250);
  DSWaveInGetErrorText(Code, PChar(S), Length(S));
  SetLength(S, StrLen(PChar(S)));
  inherited Create(S);
  FCode := Code;
end;
procedure MMCheck(Code: MMRESULT);
begin
  if Code <> MMSYSERR_NOERROR then
    raise EDSWaveIn.Create(Code);
end;
procedure MMAssert(Condition: Boolean; Code: MMRESULT);
begin
  if not Condition then
    raise EDSWaveIn.Create(Code);
end;
function HandleException: MMRESULT;
begin
  if ExceptObject is EDSWaveIn then
    Result := EDSWaveIn(ExceptObject).FCode
  else
    Result := MMSYSERR_ERROR;
end;
procedure CheckHandle(HIn: HWaveIn);
begin
  MMAssert((OpenDevices <> nil) and (OpenDevices.IndexOf(Pointer(HIn)) <> -1),
    MMSYSERR_INVALHANDLE);
end;
procedure DsNotificationThread_Addref;
begin
  if DsNotificationThread_RefCount = 0 then
    DsNotificationThread := TDsNotificationThread.Create;
  Inc(DsNotificationThread_RefCount);
end;
procedure DsNotificationThread_Release;
begin
  if DSNotificationThread_RefCount > 0 then
  begin
    Dec(DsNotificationThread_RefCount);
    if DsNotificationThread_RefCount = 0 then
    begin
      DsNotificationThread.Terminate;
      SetEvent(DsNotificationThread.FSystemEvent);
      DsNotificationThread.Free;
      DsNotificationThread := nil;
    end;
  end;
end;
function DeviceIdToGuid(DeviceID: Integer): PGUID;
begin
  if (DeviceID >= 0) and (DeviceID < DSWaveInGetNumDevs)
    then Result := PDSDRIVERDESC(CaptureDeviceList[DeviceID]).lpGuid
    else Result := nil;
end;
function IsEqualGuidEx(const p1, p2: TGUID): Boolean;
begin
  if Assigned(@p1) and Assigned(@p2) then
    Result := IsEqualGUID(p1, p2)
  else
    Result := (not Assigned(@p1) or IsEqualGUID(p1, GUID_NULL)) and
              (not Assigned(@p2) or IsEqualGUID(p2, GUID_NULL));
end;
procedure CaptureCapsToWaveInCaps(Capture: IDirectSoundCapture;
  Guid: PGUID; var Caps: TWaveInCaps);
var
  CCaps: TDSCCAPS;
  Index: Integer;
begin
  ZeroMemory(@CCaps, SizeOf(CCaps));
  CCaps.dwSize := SizeOf(CCaps);
  MMAssert(Capture.GetCaps(CCaps) = DS_OK, MMSYSERR_ERROR);
  Caps.dwFormats := CCaps.dwFormats;
  Caps.wChannels := CCaps.dwChannels;
  for Index := CaptureDeviceList.Count-1 downto 0 do
    with PDSDRIVERDESC(CaptureDeviceList[Index])^ do
      if IsEqualGuidEx(lpGUID^, Guid^) then
      begin
        StrLCopy(Caps.szPname, PChar(Description), SizeOf(Caps.szPname));
        break;
      end;
end;
 // WaveIn -> DirectCapture API
function DSWaveInGetNumDevs: UINT;
begin
  if not Assigned(CaptureDeviceList) then
  begin
    CaptureDeviceList := TList.Create;
    if LoadDSoundDLL and Assigned(DirectSoundCaptureEnumerate) then
      DirectSoundCaptureEnumerate(DriverEnumerate, CaptureDeviceList);
  end;
  Result := CaptureDeviceList.Count;
end;
function DSWaveInGetDevCaps(HIn: HWaveIn; lpCaps: PWaveInCaps; uSize: UINT): MMRESULT;
var
  Index: Integer;
  AlreadyOpened: Boolean;
  lpGuid: PGUID;
  Capture: IDirectSoundCapture;
begin
  try
     // HIn can be eather an opened device handle ...
    if Assigned(OpenDevices) and (OpenDevices.IndexOf(Pointer(HIn)) <> -1) then
    begin
      TDsWaveInDevice(HIn).GetCaps(lpCaps^)
    end else
     // ... or DeviceID ...
    if (HIn = integer(WAVE_MAPPER)) or ((HIn >= 0) and (HIn < CaptureDeviceList.Count)) then
    begin
      AlreadyOpened := False;
      lpGuid := DeviceIdToGuid(HIn);
       // Maybe it is already opened ?
      if Assigned(OpenDevices) then
        for Index := OpenDevices.Count-1 downto 0 do
          if IsEqualGuidEx(TDsWaveInDevice(OpenDevices[Index]).FGuid^,
               lpGuid^) then
          begin
            TDsWaveInDevice(OpenDevices[Index]).GetCaps(lpCaps^);
            AlreadyOpened := True;
            break;
          end;
      if not AlreadyOpened then
      begin
        MMAssert(Assigned(DirectSoundCaptureCreate), MMSYSERR_NODRIVER);
        MMAssert(DirectSoundCaptureCreate(lpGuid, Capture, nil) = DS_OK,
          MMSYSERR_NODRIVER);
        try
          CaptureCapsToWaveInCaps(Capture, lpGuid, lpCaps^);
        finally
          Capture.Release
        end;
      end;
    end else
     // ... otherwise this is an error
      CheckHandle(HIn);
    Result := MMSYSERR_NOERROR;
  except
    Result := HandleException;
  end;
end;
function DSWaveInGetErrorText(mmrError: MMRESULT; lpText: PChar; uSize: UINT): MMRESULT;
begin
  Result := waveInGetErrorText(mmrError, lpText, uSize)
end;
function DSWaveInOpen(lpHWaveIn: PHWaveIn; uDeviceID: UINT; lpFormatEx: PWaveFormatEx; dwCallback, dwInstance, dwFlags: DWORD): MMRESULT;
var
  Capture: TDsWaveInDevice;
  CallbackType: Integer;
begin
  try
     // TODO: uDeviceID cab be a handle of an open device ???
    MMAssert(LoadDSoundDLL and Assigned(DirectSoundCaptureCreate) and
      (uDeviceID < DSWaveInGetNumDevs), MMSYSERR_NODRIVER);
    MMAssert(lpFormatEx <> nil, MMSYSERR_INVALPARAM);
    MMAssert(dwFlags and WAVE_ALLOWSYNC = 0, MMSYSERR_NOTSUPPORTED);
    Capture := TDsWaveInDevice.Create(DeviceIdToGuid(uDeviceID), lpFormatEx);
    if dwFlags and WAVE_FORMAT_QUERY = 0 then
    begin
      CallbackType := CALLBACK_NULL;
      if dwFlags and CALLBACK_FUNCTION <> 0 then CallbackType := CALLBACK_FUNCTION else
      if dwFlags and CALLBACK_WINDOW   <> 0 then CallbackType := CALLBACK_WINDOW   else
      if dwFlags and CALLBACK_THREAD   <> 0 then CallbackType := CALLBACK_THREAD   else
        MMCheck(MMSYSERR_INVALPARAM);
      MMAssert(dwCallBack <> 0, MMSYSERR_INVALPARAM);
      Capture.FCallBackMode := CallbackType;
      Capture.FCallBack := dwCallback;
      Capture.FCBInstance := dwInstance;
      MMAssert(Assigned(lpHWaveIn), MMSYSERR_INVALPARAM);
      lpHWaveIn^ := HWaveIn(Capture);
      Capture.NotifyMessage(MM_WIM_OPEN, lphWaveIn^, 0);
    end else
      Capture.Free;
    Result := MMSYSERR_NOERROR;
  except
    Result := HandleException;
  end;
end;
function DSWaveInClose(HIn: HWaveIn): MMRESULT;
begin
  try
    CheckHandle(HIn);
    with TDsWaveInDevice(HIn) do
    begin
      NotifyMessage(MM_WIM_CLOSE, HIn, 0);
      Free;
    end;
    Result := MMSYSERR_NOERROR;
  except
    Result := HandleException;
  end;
end;
function DSWaveInPrepareHeader(HIn: HWaveIn; lpWaveInHdr: PWaveHdr; uSize: UINT): MMRESULT;
begin
  try
    CheckHandle(HIn);
    TDsWaveInDevice(HIn).PrepareBuffer(lpWaveInHdr);
    Result := MMSYSERR_NOERROR;
  except
    Result := HandleException;
  end;
end;
function DSWaveInUnprepareHeader(HIn: HWaveIn; lpWaveInHdr: PWaveHdr; uSize: UINT): MMRESULT;
begin
  try
    CheckHandle(HIn);
    TDsWaveInDevice(HIn).UnprepareBuffer(lpWaveInHdr);
    Result := MMSYSERR_NOERROR;
  except
    Result := HandleException;
  end;
end;
function DSWaveInAddBuffer(HIn: HWaveIn; lpWaveInHdr: PWaveHdr; uSize: UINT): MMRESULT;
begin
  try
    CheckHandle(HIn);
    TDsWaveInDevice(HIn).AddBuffer(lpWaveInHdr);
    Result := MMSYSERR_NOERROR;
  except
    Result := HandleException;
  end;
end;
function DSWaveInStart(HIn: HWaveIn): MMRESULT;
begin
  try
    CheckHandle(HIn);
    TDsWaveInDevice(HIn).Start;
    Result := MMSYSERR_NOERROR;
  except
    Result := HandleException;
  end;
end;
function DSWaveInStop(HIn: HWaveIn): MMRESULT;
begin
  try
    CheckHandle(HIn);
    TDsWaveInDevice(HIn).Stop;
    Result := MMSYSERR_NOERROR;
  except
    Result := HandleException;
  end;
end;
function DSWaveInReset(HIn: HWaveIn): MMRESULT;
begin
  try
    CheckHandle(HIn);
    TDsWaveInDevice(HIn).Reset;
    Result := MMSYSERR_NOERROR;
  except
    Result := HandleException;
  end;
end;
function DSWaveInGetPosition(HIn: HWaveIn; lpInfo: PMMTime; uSize: UINT): MMRESULT;
begin
  try
    CheckHandle(HIn);
    TDsWaveInDevice(HIn).GetPosition(lpInfo);
    Result := MMSYSERR_NOERROR;
  except
    Result := HandleException;
  end;
end;
function DSWaveInGetID(HIn: HWaveIn; lpuDeviceID: PUINT): MMRESULT;
begin
  try
    CheckHandle(HIn);
    lpuDeviceID^ := HIn;
    Result := MMSYSERR_NOERROR;
  except
    Result := HandleException;
  end;
end;
function DSWaveInMessage(HIn: HWaveIn; uMessage: UINT; dw1, dw2: DWORD): MMRESULT;
begin
  try
    CheckHandle(HIn);
     // ??? What are these messages
     // TDsWaveInDevice(HIn).NotifyMessage(uMessage, dw1, dw2);
    Result := MMSYSERR_NOERROR;
  except
    Result := HandleException;
  end;
end;
function DSWaveInGetIDirectSoundCapture(HIn: HWaveIn): IDirectSoundCapture;
begin
  Result := nil;
  try
    CheckHandle(HIn);
    Result := TDsWaveInDevice(HIn).FCapture;
  except
    ;
  end;
end;
 // TDsNotificationThread
constructor TDsNotificationThread.Create;
begin
   inherited Create(False);
   FSystemEvent := CreateEvent(nil, False, False, nil);
end;
destructor TDsNotificationThread.Destroy;
begin
   CloseHandle(FSystemEvent);
   inherited;
end;
procedure TDsNotificationThread.Execute;
type
  TDeviceArray = array[0..0] of TDsWaveInDevice;
  PDeviceArray = ^TDeviceArray;
var
  HandleCount: Integer;
  Handles: PWOHandleArray;
  Devices: PDeviceArray;
  procedure CollectHandles;
  var
    Index, HandleIndex, i,
    DeviceCount: Integer;
    Device: TDsWaveInDevice;
  begin
    TDsWaveInDevice.EnterCritical;
    try
      DeviceCount := OpenDevices.Count;
      HandleCount := 1;
      for Index := 0 to DeviceCount-1 do
      begin
        Device := OpenDevices[Index];
        Inc(HandleCount, Device.FBufferCount + 1);
      end;
      GetMem(Handles, HandleCount * SizeOf(THandle));
      GetMem(Devices, HandleCount * SizeOf(Devices^[0]));
      HandleIndex := 0;
      for Index := 0 to DeviceCount-1 do
      begin
        Device := OpenDevices[Index];
        for i := 0 to Device.FBufferCount do
        begin
          Handles^[HandleIndex] := Device.FNotifyPts[i].hEventNotify;
          Devices^[HandleIndex] := Device;
          Inc(HandleIndex);
        end;
      end;
      Handles^[HandleIndex] := FSystemEvent;
      Devices^[HandleIndex] := nil;
    finally
      TDsWaveInDevice.LeaveCritical;
    end;
  end;
  procedure FreeHandles;
  begin
    FreeMem(Handles, HandleCount * SizeOf(THandle));
    FreeMem(Devices, HandleCount * SizeOf(Devices^[0]));
    Handles := nil;
    Devices := nil;
  end;
var
  WaitResult, PointNumber: Integer;
begin
  while not Terminated do
  begin
    Priority := tpHigher;
    CollectHandles;
    WaitResult := WaitForMultipleObjects(HandleCount, Handles,
      False, NOTIFICATIONTHREAD_TIMEOUT) - WAIT_OBJECT_0;
{$IFDEF _MMDEBUG}
//    DB_FormatLn(0, 'Thread received result: %d', [WaitResult]);
{$ENDIF}
    if WaitResult = HandleCount - 1 then
       { System Event - do nothing just starting another loop }
    else if (WaitResult >= 0) and (WaitResult < HandleCount - 1) then
    begin
       { Process next block ... }
      PointNumber := 0;
      while WaitResult > PointNumber do
        if Devices^[WaitResult - PointNumber - 1] = Devices^[WaitResult] then
          Inc(PointNumber);
       // It's possible that buffer has already been destroyed
       // while the thread was waiting to be activated
      with Devices^[WaitResult] do
        if Assigned(FBuffer) then ProcessData(PointNumber);
    end;
    FreeHandles;
  end;
end;
 // TDsWaveInDevice
var
  DataSection: TRtlCriticalSection;
  DataSectionOK: Boolean = False;
constructor TDsWaveInDevice.Create(DeviceGuid: PGUID; lpFormat: PWaveFormatEx);
begin
  inherited Create;
  FWaveBuffers := TList.Create;
  FQueue := TList.Create;
  MMAssert(DirectSoundCaptureCreate(DeviceGuid, FCapture, nil) = S_OK,
    MMSYSERR_NODRIVER);
  FGuid := DeviceGuid;
  Reconfigure(lpFormat, DEFAULT_BUFFERCOUNT, DEFAULT_BUFFERSIZE);
  DsNotificationThread_Addref;
   // Global Initializations
  if not DataSectionOK then
  begin
    ZeroMemory(@DataSection, SizeOf(DataSection));
    InitializeCriticalSection(DataSection);
    DataSectionOK := True;
  end;
  EnterCritical;
  if OpenDevices = nil then
    OpenDevices := TList.Create;
  OpenDevices.Add(Self);
  FState := wdsIdle;
  LeaveCritical;
  SetEvent(DsNotificationThread.FSystemEvent);
end;
destructor TDsWaveInDevice.Destroy;
var
  i: integer;
begin
  Reset;
  for i := FWaveBuffers.Count-1 downto 0 do
    TDsWaveBuffer(FWaveBuffers[i]).Free;
  FWaveBuffers.Clear;
  EnterCritical;
  if OpenDevices <> nil then
    OpenDevices.Remove(Self);
  LeaveCritical;
  Reconfigure(nil, 0, 0);
  if Assigned(FCapture) then
  begin
    FCapture.Release;
    FCapture := nil;
  end;
  FQueue.Free;
  FWaveBuffers.Free;
  inherited;
end;
class procedure TDsWaveInDevice.EnterCritical;
begin
  if DataSectionOK then
    EnterCriticalSection(DataSection);
end;
class procedure TDsWaveInDevice.LeaveCritical;
begin
  if DataSectionOK then
    LeaveCriticalSection(DataSection);
end;
procedure TDsWaveInDevice.Reconfigure(lpFormat: PWaveFormatEx; ABufCount, ABufSize: Integer);
var
  BufferDesc: TDSCBUFFERDESC;
  Caps: TDSCBCAPS;
  i: Integer;
begin
  EnterCritical;
  try
    if Assigned(FNotifications) then
    begin
      for i := 0 to FBufferCount do
        with FNotifyPts^[i] do CloseHandle(hEventNotify);
      FreeMem(FNotifyPts);
      FNotifyPts := nil;
      FNotifications.Release;
      FNotifications := nil;
    end;
    if Assigned(FBuffer) then
    begin
      FBuffer.Release;
      FBuffer := nil;
    end;
    if lpFormat <> nil then
    begin
      if ABufCount < DEFAULT_BUFFERCOUNT then
        ABufCount := DEFAULT_BUFFERCOUNT;
      FBufferCount := ABufCount;
      FBufferPartSize := ABufSize - (ABufSize mod lpFormat^.nBlockAlign);
      FBufferSize := FBufferPartSize * FBufferCount;
      ZeroMemory(@BufferDesc, SizeOf(BufferDesc));
      with BufferDesc do
      begin
        dwSize := SizeOf(BufferDesc);
        dwFlags := DSCBCAPS_WAVEMAPPED;
        dwBufferBytes := FBufferSize;
        lpwfxFormat := lpFormat;
      end;
      MMAssert(FCapture.CreateCaptureBuffer(BufferDesc, FBuffer, nil) = S_OK,
        MMSYSERR_INVALPARAM);
      ZeroMemory(@Caps, SizeOf(Caps));
      Caps.dwSize := SizeOf(Caps);
      FBuffer.GetCaps(Caps);
      FWaveMapped := Caps.dwFlags and DSCBCAPS_WAVEMAPPED > 0;
      MMAssert(FBuffer.QueryInterface(IID_IDirectSoundNotify, FNotifications) = S_OK,
        MMSYSERR_NOTSUPPORTED);
     // FNotifications.AddRef; // Does not seem to be required (?)
      FNotifyPts := AllocMem(SizeOf(FNotifyPts^[0]) * (FBufferCount + 1));
      for i := 0 to FBufferCount-1 do
        with FNotifyPts^[i] do
        begin
          dwOffset := (i + 1) * FBufferPartSize - lpFormat^.nBlockAlign;
          hEventNotify := CreateEvent(nil, False, False, nil);
        end;
      with FNotifyPts^[FBufferCount] do
      begin
        dwOffset := DSBPN_OFFSETSTOP;
        hEventNotify := CreateEvent(nil, False, False, nil);
      end;
      MMAssert(FNotifications.SetNotificationPositions(FBufferCount + 1,
        @FNotifyPts^[0]) = S_OK, MMSYSERR_NOTSUPPORTED);
    end;
  finally
    LeaveCritical;
    if Assigned(DsNotificationThread) then
      SetEvent(DsNotificationThread.FSystemEvent);
  end;
end;
procedure TDsWaveInDevice.NotifyMessage(Msg: UINT; wParam: WPARAM; lParam: LPARAM); stdcall;
type
  TWaveInFunc = procedure(HIn: HWaveIn; wMsg:UINT; dwInstance, dwParam1, dwParam2:Longint); stdcall;
begin
  case FCallBackMode of
    CALLBACK_WINDOW:
      PostMessage(FCallBack, Msg, wParam, lParam);
    CALLBACK_THREAD:
      PostThreadMessage(FCallBack, Msg, wParam, lParam);
    CALLBACK_FUNCTION:
      TWaveInFunc(FCallBack)(HWaveIn(Self), Msg, FCBInstance, lParam, 0);
  end;
end;
procedure TDsWaveInDevice.GetCaps(var Caps: TWaveInCaps);
begin
  CaptureCapsToWaveInCaps(FCapture, FGuid, Caps);
end;
function TDsWaveInDevice.GetFormat: PWaveFormatEx;
var
  wf: TWaveFormatEx;
begin
  MMAssert(FBuffer.GetFormat(@wf, SizeOf(wf), DWORD(nil^)) = DS_OK,
    MMSYSERR_ERROR);
   // Warning!!! the result remains on stack, so be careful with it
  Result := @wf;
end;
procedure TDsWaveInDevice.SetFormat(Value: PWaveFormatEx);
begin
  MMCheck(MMSYSERR_NOTSUPPORTED);
end;
function TDsWaveInDevice.CaptureActive: Boolean;
var
  Status: DWORD;
begin
  if Assigned(FBuffer) then
  begin
    MMAssert(FBuffer.GetStatus(Status) = DS_OK, MMSYSERR_ERROR);
    Result := Status and DSCBSTATUS_CAPTURING <> 0;
  end else
    Result := False;
end;
procedure TDsWaveInDevice.ProcessData(PointNumber: Integer);
var
   // Cursors have DirectX buffer as origin,
   // Positions - capture reset
  CaptureCursor, ReadCursor: DWORD;
  WriteCursor, ReadPosition: integer;
  procedure PassData(P: Pointer; L: Integer);
  var
    Buffer: TDsWaveBuffer;
    L0, L1: Integer;
  begin
    L0 := L;
    while (FQueue.Count > 0) and (L0 > 0) do
    begin
      Buffer := FQueue[0];
      L1 := L0;
      if Buffer.Accept(P, L1) then
        ReturnBuffer;
      Dec(L0, L1);
      Inc(PChar(P), L1);
    end;
    if L0 > 0 then Stop;
  end;
  procedure TakeData(FromCursor, ToCursor: Integer);
  var
    Length: Integer;
    p1, p2: Pointer;
    l1, l2: DWORD;
  begin
    Length := ToCursor - FromCursor;
    if Length > 0 then
    begin
{$IFDEF _MMDEBUG}
      DB_FormatLn(0, 'Locking buffer at %5d - %5d', [FromCursor, ToCursor]);
{$ENDIF}
      MMAssert(FBuffer.Lock(FromCursor, Length, p1, l1, p2, l2, 0) = DS_OK,
        MMSYSERR_ERROR);
      try
        PassData(p1, l1);
        if l2 > 0 then PassData(p2, l2);
      finally
        MMAssert(FBuffer.Unlock(p1, l1, p2, l2) = DS_OK, MMSYSERR_ERROR);
      end;
    end
  end;
begin
  EnterCritical;
  try
    if PointNumber = FBufferCount - 1 then
      Inc(FBufferOrigin, FBufferSize);
    MMAssert(FBuffer.GetCurrentPosition(CaptureCursor, ReadCursor) = DS_OK,
      MMSYSERR_ERROR);
    ReadPosition := FBufferOrigin + ReadCursor;
    if ReadPosition > FWritePosition then
    begin
      WriteCursor := FWritePosition - FBufferOrigin;
      if WriteCursor < 0 then
      begin
         // Check overflow
        if WriteCursor < ReadCursor - FBufferSize then
          WriteCursor := ReadCursor - FBufferSize;
        TakeData(WriteCursor + FBufferSize, FBufferSize);
        TakeData(0, ReadCursor);
      end else
        TakeData(WriteCursor, ReadCursor);
      FWritePosition := ReadPosition;
    end;
  except
    try
      Stop;
    except
      // Something bad happenned if we are there...
    end;
  end;
  LeaveCritical;
end;
function TDsWaveInDevice.FindBuffer(Header: PWaveHdr): TDsWaveBuffer;
var
  Index: Integer;
begin
  for Index := FWaveBuffers.Count-1 downto 0 do
  begin
    Result := FWaveBuffers[Index];
    if Result.Data = Header then
      exit;
  end;
  Result := nil;
end;
procedure TDsWaveInDevice.ReturnBuffer;
var
  Buffer: TDsWaveBuffer;
begin
  if FQueue.Count > 0 then
  begin
    Buffer := FQueue[0];
    FQueue.Delete(0);
    with Buffer.Data^ do
      dwFlags := dwFlags and not WHDR_INQUEUE or WHDR_DONE;
    NotifyMessage(MM_WIM_DATA, HWaveIn(Self), Integer(Buffer.Data));
  end;
end;
procedure TDsWaveInDevice.AddBuffer(Header: PWaveHdr);
var
  Buffer: TDsWaveBuffer;
begin
  Buffer := FindBuffer(Header);
  MMAssert(Assigned(Buffer) and (Buffer.FData.dwFlags and WHDR_PREPARED <> 0),
    WAVERR_UNPREPARED);
  with Buffer.Data^ do
  begin
    dwFlags := dwFlags and not WHDR_DONE or WHDR_INQUEUE;
    dwBytesRecorded := 0;
    lpNext := nil;
  end;
  EnterCritical;
  if FQueue.Count > 0 then
    TDsWaveBuffer(FQueue[FQueue.Count-1]).Data.lpNext := Buffer.Data;
  FQueue.Add(Buffer);
  LeaveCritical;
end;
procedure TDsWaveInDevice.PrepareBuffer(Header: PWaveHdr);
var
  Buffer: TDsWaveBuffer;
  i, MinBufferSize: Integer;
  wfx: TWaveFormatEx;
begin
  MMAssert(Header^.dwFlags and WHDR_PREPARED = 0, MMSYSERR_INVALPARAM);
  Header^.dwFlags := WHDR_PREPARED;
  Buffer := TDsWaveBuffer.Create(Header);
  FWaveBuffers.Add(Buffer);
   // Reconfigure internal buffers so that they match outer ones
  if FState in [wdsInactive, wdsIdle] then
  begin
    MinBufferSize := Header.dwBufferLength;
    for i := FWaveBuffers.Count-1 downto 0 do
    begin
      Buffer := FWaveBuffers[i];
      if Buffer.Data.dwBufferLength < MinBufferSize then
        MinBufferSize := Buffer.Data.dwBufferLength;
    end;
    if (MinBufferSize <> FBufferPartSize) or
       (FWaveBuffers.Count >= DEFAULT_BUFFERCOUNT) and
       ((FWaveBuffers.Count >= FBufferCount shl 1) or
        (FWaveBuffers.Count shl 1 <= FBufferCount)) then
    begin
      wfx := Format^;
      Reconfigure(@wfx, FWaveBuffers.Count, MinBufferSize);
    end;
  end;
end;
procedure TDsWaveInDevice.UnprepareBuffer(Header: PWaveHdr);
var
  Buffer: TDsWaveBuffer;
begin
  Buffer := FindBuffer(Header);
  MMAssert(Assigned(Buffer) and (Header^.dwFlags and WHDR_PREPARED <> 0),
    MMSYSERR_INVALPARAM);
  MMAssert(FQueue.IndexOf(Buffer) = -1, WAVERR_STILLPLAYING);
  EnterCritical;
  Buffer.Free;
  FWaveBuffers.Remove(Buffer);
  LeaveCritical;
  with Header^ do
    dwFlags := dwFlags and not WHDR_PREPARED;
end;
procedure TDsWaveInDevice.Start;
begin
  if not CaptureActive then
    MMAssert(FBuffer.Start(DSCBSTART_LOOPING) = DS_OK, MMSYSERR_ERROR);
  FState := wdsStarted;
end;
procedure TDsWaveInDevice.Stop;
begin
  if CaptureActive then
  begin
    MMAssert(FBuffer.Stop = DS_OK, MMSYSERR_ERROR);
    if (FQueue.Count > 0) and
       (TDsWaveBuffer(FQueue[0]).Data.dwBytesRecorded > 0) then
      ReturnBuffer;
  end;
  FState := wdsIdle;
end;
procedure TDsWaveInDevice.Reset;
begin
  Stop;
  while FQueue.Count > 0 do
    ReturnBuffer;
end;
procedure TDsWaveInDevice.GetPosition(lpInfo: PMMTime);
var
  CaptureCursor, ReadCursor: DWORD;
begin
  MMAssert(lpInfo <> nil, MMSYSERR_INVALPARAM);
  MMAssert(FBuffer.GetCurrentPosition(CaptureCursor, ReadCursor) = DS_OK,
    MMSYSERR_ERROR);
  lpInfo^.cb := FBufferOrigin + CaptureCursor;
  with lpInfo^ do case wType of
    TIME_BYTES:
      ;
    TIME_MS:
      ms := MulDiv(cb, 1000, Format.nAvgBytesPerSec);
    TIME_SAMPLES:
      sample := MulDiv(cb, 1000, Format.nBlockAlign);
  else
    MMCheck(MMSYSERR_INVALFLAG);
  end;
end;
 // TDsWaveBuffer
constructor TDsWaveBuffer.Create(lpWaveHdr: PWaveHdr);
begin
  inherited Create;
  FData := lpWaveHdr;
end;
function TDsWaveBuffer.CanAccept: Integer;
begin
  with FData^ do
    Result := dwBufferLength - dwBytesRecorded;
end;
function TDsWaveBuffer.Accept(WaveData: Pointer; var Length: Integer): Boolean;
var
  FreeRoom: Integer;
begin
  FreeRoom := CanAccept;
  Result := Length >= FreeRoom;
  if Result then
    Length := FreeRoom;
  with FData^ do
  begin
    CopyMemory(lpData + dwBytesRecorded, WaveData, Length);
    Inc(dwBytesRecorded, Length);
  end;
end;
procedure Cleanup;
var
  i: integer;
begin
  if Assigned(CaptureDeviceList) then
  begin
    FreeDriverList(CaptureDeviceList);
    CaptureDeviceList.Free;
    CaptureDeviceList := nil
  end;
  if Assigned(OpenDevices) then
  begin
    for i := OpenDevices.Count-1 downto 0 do
      TObject(OpenDevices[i]).Free;
    OpenDevices.Free;
    OpenDevices := nil;
  end;
  if DataSectionOK then
  begin
    DataSectionOK := False;
    DeleteCriticalSection(DataSection);
  end;
end;
// Initialization
initialization
finalization
   CleanUp;
end.

						