mmdscptr.pas

一套及时通讯的原码

{========================================================================}
{=                (c) 1995-98 SwiftSoft Ronald Dittrich                 =}
{========================================================================}
{=                          All Rights Reserved                         =}
{========================================================================}
{=  D 01099 Dresden             = Fax.: [phone]              =}
{=  Loewenstr.7a                = [e-mail]                     =}
{========================================================================}
{=  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