dxsounds.pas

VCL component dsplab , STFT and SPECTRUM viewer, real time

unit DXSounds;

interface

uses
  Windows, Messages, SysUtils, Classes, Controls, Forms, ExtCtrls, MMSystem,
  DirectX, DXClass, Wave, Math;

type

  {  EDirectSoundError  }

  EDirectSoundError = class(EDirectXError);
  EDirectSoundBufferError = class(EDirectSoundError);

  {  TDirectSound  }

  TDirectSoundBuffer = class;

  TDirectSound = class(TDirectX)
  private
    FBufferList: TList;
    FGlobalFocus: Boolean;
    FIDSound: IDirectSound;
    FInRestoreBuffer: Boolean;
    FStickyFocus: Boolean;
    function GetBuffer(Index: Integer): TDirectSoundBuffer;
    function GetBufferCount: Integer;
    function GetIDSound: IDirectSound;
    function GetISound: IDirectSound;
  protected          
    procedure CheckBuffer(Buffer: TDirectSoundBuffer);
    procedure DoRestoreBuffer; virtual;
  public
    constructor Create(GUID: PGUID);
    destructor Destroy; override;
    class function Drivers: TDirectXDrivers;
    property BufferCount: Integer read GetBufferCount;
    property Buffers[Index: Integer]: TDirectSoundBuffer read GetBuffer;
    property IDSound: IDirectSound read GetIDSound;
    property ISound: IDirectSound read GetISound;
  end;

  {  TDirectSoundBuffer  }

  TDirectSoundBuffer = class(TDirectX)
  private
    FDSound: TDirectSound;
    FIDSBuffer: IDirectSoundBuffer;
    FCaps: TDSBCaps;
    FFormat: PWaveFormatEx;
    FFormatSize: Integer;
    FLockAudioPtr1, FLockAudioPtr2: array[0..0] of Pointer;
    FLockAudioSize1, FLockAudioSize2: array[0..0] of DWORD;
    FLockCount: Integer;
    function GetBitCount: Longint;
    function GetFormat: PWaveFormatEx;
    function GetFrequency: Integer;
    function GetIDSBuffer: IDirectSoundBuffer;
    function GetIBuffer: IDirectSoundBuffer;
    function GetPlaying: Boolean;
    function GetPan: Integer;
    function GetPosition: Longint;
    function GetSize: Integer;
    function GetStatus: Integer;
    function GetVolume: Integer;
    procedure SetFrequency(Value: Integer);
    procedure SetIDSBuffer(Value: IDirectSoundBuffer);
    procedure SetPan(Value: Integer);
    procedure SetPosition(Value: Longint);
    procedure SetVolume(Value: Integer);
  protected
    procedure Check; override;
  public
    constructor Create(ADirectSound: TDirectSound);
    destructor Destroy; override;
    procedure Assign(Source: TPersistent); override;
    function CreateBuffer(const BufferDesc: TDSBufferDesc): Boolean;
    procedure LoadFromMemory(const Format: TWaveFormatEx;
      Data: Pointer; Size: Integer);
    function Lock(LockPosition, LockSize: Longint;
      var AudioPtr1: Pointer; var AudioSize1: Longint;
      var AudioPtr2: Pointer; var AudioSize2: Longint): Boolean;
    function Play(Loop: Boolean=False): Boolean;
    function Restore: Boolean;
    function SetFormat(const Format: TWaveFormatEx): Boolean;
    procedure SetSize(const Format: TWaveFormatEx; Size: Integer);
    procedure Stop;
    procedure UnLock;
    property BitCount: Longint read GetBitCount;
    property DSound: TDirectSound read FDSound;
    property Format: PWaveFormatEx read GetFormat;
    property FormatSize: Integer read FFormatSize;
    property Frequency: Integer read GetFrequency write SetFrequency;
    property IBuffer: IDirectSoundBuffer read GetIBuffer;
    property IDSBuffer: IDirectSoundBuffer read GetIDSBuffer write SetIDSBuffer;
    property Playing: Boolean read GetPlaying;
    property Pan: Integer read GetPan write SetPan;
    property Position: Longint read GetPosition write SetPosition;
    property Size: Integer read GetSize;
    property Volume: Integer read GetVolume write SetVolume;
  end;


  {  TSoundCaptureFormat  }

  TSoundCaptureFormat = class(TCollectionItem)
  private
    FBitsPerSample: Integer;
    FChannels: Integer;
    FSamplesPerSec: Integer;
  public
    property BitsPerSample: Integer read FBitsPerSample;
    property Channels: Integer read FChannels;
    property SamplesPerSec: Integer read FSamplesPerSec;
  end;

  {  TSoundCaptureFormats  }

  TSoundCaptureFormats = class(TCollection)
  private
    function GetItem(Index: Integer): TSoundCaptureFormat;
  public
    constructor Create;
    function IndexOf(ASamplesPerSec, ABitsPerSample, AChannels: Integer): Integer;
    property Items[Index: Integer]: TSoundCaptureFormat read GetItem; default;
  end;

  {  TSoundCaptureStream  }

  ESoundCaptureStreamError = class(EWaveStreamError);

  TSoundCaptureStream = class(TCustomWaveStream2)
  private
    FBuffer: IDirectSoundCaptureBuffer;
    FBufferLength: Integer;
    FBufferPos: DWORD;
    FBufferSize: DWORD;
    FCapture: IDirectSoundCapture;
    FCaptureFormat: Integer;
    FCapturing: Boolean;
    FNotifyEvent: THandle;
    FNotifyThread: TThread;
    FOnFilledBuffer: TNotifyEvent;
    FSupportedFormats: TSoundCaptureFormats;
    function GetReadSize: Integer;
    procedure SetBufferLength(Value: Integer);
    procedure SetOnFilledBuffer(Value: TNotifyEvent);
  protected
    procedure DoFilledBuffer; virtual;
    function GetFilledSize: Integer; override;
    function ReadWave(var Buffer; Count: Integer): Integer; override;
  public
    constructor Create(GUID: PGUID);
    destructor Destroy; override;
    class function Drivers: TDirectXDrivers;
    procedure Start;
    procedure Stop;
    property BufferLength: Integer read FBufferLength write SetBufferLength;
    property CaptureFormat: Integer read FCaptureFormat write FCaptureFormat;
    property Capturing: Boolean read FCapturing;
    property OnFilledBuffer: TNotifyEvent read FOnFilledBuffer write SetOnFilledBuffer;
    property SupportedFormats: TSoundCaptureFormats read FSupportedFormats;
  end;

  {  EDXSoundError  }

  EDXSoundError = class(Exception);

  {  TCustomDXSound  }

  TCustomDXSound = class;

  TDXSoundOption = (soGlobalFocus, soStickyFocus, soExclusive);
  TDXSoundOptions = set of TDXSoundOption;

  TDXSoundNotifyType = (dsntDestroying, dsntInitializing, dsntInitialize, dsntFinalize, dsntRestore);
  TDXSoundNotifyEvent = procedure(Sender: TCustomDXSound; NotifyType: TDXSoundNotifyType) of object;

  TCustomDXSound = class(TComponent)
  private
    FAutoInitialize: Boolean;
    FCalledDoInitialize: Boolean;
    FDriver: PGUID;
    FDriverGUID: TGUID;
    FDSound: TDirectSound;
    FForm: TCustomForm;
    FInitialized: Boolean;
    FInternalInitialized: Boolean;
    FNowOptions: TDXSoundOptions;
    FOnFinalize: TNotifyEvent;
    FOnInitialize: TNotifyEvent;
    FOnInitializing: TNotifyEvent;
    FOptions: TDXSoundOptions;
    FPrimary: TDirectSoundBuffer;
    FSubClass: TControlSubClass;
    procedure FormWndProc(var Message: TMessage; DefWindowProc: TWndMethod);
    procedure SetDriver(Value: PGUID);
    procedure SetForm(Value: TCustomForm);
    procedure SetOptions(Value: TDXSoundOptions);
  protected
    procedure DoFinalize; virtual;
    procedure DoInitialize; virtual;
    procedure DoInitializing; virtual;
    procedure Loaded; override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    class function Drivers: TDirectXDrivers;
    procedure Finalize;
    procedure Initialize;

    property AutoInitialize: Boolean read FAutoInitialize write FAutoInitialize;
    property Driver: PGUID read FDriver write SetDriver;
    property DSound: TDirectSound read FDSound;
    property Initialized: Boolean read FInitialized;
    property NowOptions: TDXSoundOptions read FNowOptions;
    property Primary: TDirectSoundBuffer read FPrimary;
    property OnFinalize: TNotifyEvent read FOnFinalize write FOnFinalize;
    property OnInitialize: TNotifyEvent read FOnInitialize write FOnInitialize;
    property OnInitializing: TNotifyEvent read FOnInitializing write FOnInitializing;
    property Options: TDXSoundOptions read FOptions write SetOptions;
  end;

  {  TDXSound  }

  TDXSound = class(TCustomDXSound)
  published
    property AutoInitialize;
    property Options;
    property OnFinalize;
    property OnInitialize;
    property OnInitializing;
  end;


implementation

uses DXConsts;

function DXDirectSoundCreate(lpGUID: PGUID; out lpDS: IDirectSound;
  pUnkOuter: IUnknown): HRESULT;
type
  TDirectSoundCreate = function(lpGUID: PGUID; out lplpDD: IDirectSound;
    pUnkOuter: IUnknown): HRESULT; stdcall;
begin
  Result := TDirectSoundCreate(DXLoadLibrary('DSound.dll', 'DirectSoundCreate'))
    (lpGUID, lpDS, pUnkOuter);
end;

function DXDirectSoundEnumerate(lpCallback: TDSEnumCallbackA;
    lpContext: Pointer): HRESULT;
type
  TDirectSoundEnumerate = function(lpCallback: TDSEnumCallbackA;
    lpContext: Pointer): HRESULT; stdcall;
begin
  Result := TDirectSoundEnumerate(DXLoadLibrary('DSound.dll', 'DirectSoundEnumerateA'))
    (lpCallback, lpContext);
end;

function DXDirectSoundCaptureCreate(lpGUID: PGUID; out lplpDSC: IDirectSoundCapture;
  pUnkOuter: IUnknown): HRESULT;
type
  TDirectSoundCaptureCreate = function(lpGUID: PGUID; out lplpDD: IDirectSoundCapture;
    pUnkOuter: IUnknown): HRESULT; stdcall;
begin
  try
    Result := TDirectSoundCaptureCreate(DXLoadLibrary('DSound.dll', 'DirectSoundCaptureCreate'))
      (lpGUID, lplpDSC, pUnkOuter);
  except
    raise EDirectXError.Create(SSinceDirectX5);
  end;
end;

function DXDirectSoundCaptureEnumerate(lpCallback: TDSEnumCallbackA;
    lpContext: Pointer): HRESULT;
type
  TDirectSoundCaptureEnumerate = function(lpCallback: TDSEnumCallbackA;
    lpContext: Pointer): HRESULT; stdcall;
begin
  try
    Result := TDirectSoundCaptureEnumerate(DXLoadLibrary('DSound.dll', 'DirectSoundCaptureEnumerateA'))
      (lpCallback, lpContext);
  except
    raise EDirectXError.Create(SSinceDirectX5);
  end;
end;

var
  DirectSoundDrivers: TDirectXDrivers;
  DirectSoundCaptureDrivers: TDirectXDrivers;

function EnumDirectSoundDrivers_DSENUMCALLBACK(lpGuid: PGUID; lpstrDescription: LPCSTR;
  lpstrModule: LPCSTR; lpContext: Pointer): BOOL; stdcall;
begin
  Result := True;
  with TDirectXDriver.Create(TDirectXDrivers(lpContext)) do
  begin
    Guid := lpGuid;
    Description := lpstrDescription;
    DriverName := lpstrModule;
  end;
end;

function EnumDirectSoundDrivers: TDirectXDrivers;
begin
  if DirectSoundDrivers=nil then
  begin
    DirectSoundDrivers := TDirectXDrivers.Create;
    try
      DXDirectSoundEnumerate(@EnumDirectSoundDrivers_DSENUMCALLBACK, DirectSoundDrivers);
    except
      DirectSoundDrivers.Free;
      raise;
    end;
  end;

  Result := DirectSoundDrivers;
end;

function EnumDirectSoundCaptureDrivers: TDirectXDrivers;
begin
  if DirectSoundCaptureDrivers=nil then
  begin
    DirectSoundCaptureDrivers := TDirectXDrivers.Create;
    try
      DXDirectSoundCaptureEnumerate(@EnumDirectSoundDrivers_DSENUMCALLBACK, DirectSoundCaptureDrivers);
    except
      DirectSoundCaptureDrivers.Free;
      raise;
    end;
  end;

  Result := DirectSoundCaptureDrivers;
end;

{  TDirectSound  }

constructor TDirectSound.Create(GUID: PGUID);
begin
  inherited Create;
  FBufferList := TList.Create;

  if DXDirectSoundCreate(GUID, FIDSound, nil)<>DS_OK then
    raise EDirectSoundError.CreateFmt(SCannotInitialized, [SDirectSound]);
end;

destructor TDirectSound.Destroy;
begin
  while BufferCount>0 do
    Buffers[BufferCount-1].Free;
  FBufferList.Free;

  FIDSound := nil;
  inherited Destroy;
end;

class function TDirectSound.Drivers: TDirectXDrivers;
begin
  Result := EnumDirectSoundDrivers;
end;

procedure TDirectSound.CheckBuffer(Buffer: TDirectSoundBuffer);
begin
  case Buffer.DXResult of
    DSERR_BUFFERLOST:
      begin
        if not FInRestoreBuffer then
        begin
          FInRestoreBuffer := True;
          try
            DoRestoreBuffer;
          finally
            FInRestoreBuffer := False;
          end;
        end;
      end;
  end;
end;

procedure TDirectSound.DoRestoreBuffer;
begin
end;

function TDirectSound.GetBuffer(Index: Integer): TDirectSoundBuffer;
begin
  Result := FBufferList[Index];
end;

function TDirectSound.GetBufferCount: Integer;
begin
  Result := FBufferList.Count;
end;

function TDirectSound.GetIDSound: IDirectSound;
begin