dxsounds.pas

VCL component dsplab , STFT and SPECTRUM viewer, real time

begin
  inherited Create;
  FBufferLength := 1000;
  FSupportedFormats := TSoundCaptureFormats.Create;

  if DXDirectSoundCaptureCreate(GUID, FCapture, nil)<>DS_OK then
    raise ESoundCaptureStreamError.CreateFmt(SCannotInitialized, [SDirectSoundCapture]);

  {  The supported format list is acquired.  }
  for ASamplesPerSec:=Low(SamplesPerSecList) to High(SamplesPerSecList) do
    for ABitsPerSample:=Low(BitsPerSampleList) to High(BitsPerSampleList) do
      for AChannels:=Low(ChannelsList) to High(ChannelsList) do
      begin
        {  Test  }
        MakePCMWaveFormatEx(Format, SamplesPerSecList[ASamplesPerSec], BitsPerSampleList[ABitsPerSample], ChannelsList[AChannels]);

        FillChar(dscbd, SizeOf(dscbd), 0);
        dscbd.dwSize := SizeOf(dscbd);
        dscbd.dwBufferBytes := Format.nAvgBytesPerSec;
        dscbd.lpwfxFormat := @Format;

        {  If the buffer can be made,  the format of present can be used.  }
        if FCapture.CreateCaptureBuffer(dscbd, TempBuffer, nil)=DS_OK then
        begin
          TempBuffer := nil;
          with TSoundCaptureFormat.Create(FSupportedFormats) do
          begin
            FSamplesPerSec := Format.nSamplesPerSec;
            FBitsPerSample := Format.wBitsPerSample;
            FChannels := Format.nChannels;
          end;
        end;
      end;
end;

destructor TSoundCaptureStream.Destroy;
begin
  Stop;
  FSupportedFormats.Free;
  inherited Destroy;
end;

procedure TSoundCaptureStream.DoFilledBuffer;
begin
  if Assigned(FOnFilledBuffer) then FOnFilledBuffer(Self);
end;

class function TSoundCaptureStream.Drivers: TDirectXDrivers;
begin
  Result := EnumDirectSoundCaptureDrivers;
end;

function TSoundCaptureStream.GetFilledSize: Integer;
begin
  Result := GetReadSize;
end;

function TSoundCaptureStream.GetReadSize: Integer;
var
  CapturePosition, ReadPosition: DWORD;
begin
  if FBuffer.GetCurrentPosition(CapturePosition, ReadPosition)=DS_OK then
  begin
    if FBufferPos<=ReadPosition then
      Result := ReadPosition - FBufferPos
    else
      Result := FBufferSize - FBufferPos + ReadPosition;
  end else
    Result := 0;
end;

function TSoundCaptureStream.ReadWave(var Buffer; Count: Integer): Integer;
var
  Size: Integer;
  Data1, Data2: Pointer;
  Data1Size, Data2Size: DWORD;
  C: Byte;
begin
  if not FCapturing then
    Start;

  Result := 0;
  while Result<Count do
  begin
    Size := Min(Count-Result, GetReadSize);
    if Size>0 then
    begin
      if FBuffer.Lock(FBufferPos, Size, Data1, Data1Size, Data2, Data2Size, 0)=DS_OK then
      begin
        Move(Data1^, Pointer(Integer(@Buffer)+Result)^, Data1Size);
        Result := Result + Integer(Data1Size);

        if Data2<>nil then
        begin
          Move(Data2^, Pointer(Integer(@Buffer)+Result)^, Data2Size);
          Result := Result + Integer(Data1Size);
        end;

        FBuffer.UnLock(Data1, Data1Size, Data2, Data2Size);
        FBufferPos := (FBufferPos + Data1Size + Data2Size) mod FBufferSize;
      end else
        Break;
    end;
    if Result<Count then Sleep(50);
  end;

  case Format^.wBitsPerSample of
     8: C := $80;
    16: C := $00;
  else
    C := $00;
  end;

  FillChar(Pointer(Integer(@Buffer)+Result)^, Count-Result, C);
  Result := Count;
end;

procedure TSoundCaptureStream.SetBufferLength(Value: Integer);
begin
  FBufferLength := Max(Value, 0);
end;

procedure TSoundCaptureStream.SetOnFilledBuffer(Value: TNotifyEvent);
begin
  if CompareMem(@TMethod(FOnFilledBuffer), @TMethod(Value), SizeOf(TMethod)) then Exit;

  if FCapturing then
  begin
    if Assigned(FOnFilledBuffer) then
      FNotifyThread.Free;

    FOnFilledBuffer := Value;

    if Assigned(FOnFilledBuffer) then
    begin
      FNotifyThread := TSoundCaptureStreamNotify.Create(Self);
      FNotifyThread.Resume;
    end;
  end else
    FOnFilledBuffer := Value;
end;

procedure TSoundCaptureStream.Start;
var
  dscbd: TDSCBufferDesc;
begin
  Stop;
  try
    FCapturing := True;

    FormatSize := SizeOf(TWaveFormatEx);
    with FSupportedFormats[CaptureFormat] do
      MakePCMWaveFormatEx(Format^, SamplesPerSec, BitsPerSample, Channels);

    FBufferSize := Max(MulDiv(Format^.nAvgBytesPerSec, FBufferLength, 1000), 8000);

    FillChar(dscbd, SizeOf(dscbd), 0);
    dscbd.dwSize := SizeOf(dscbd);
    dscbd.dwBufferBytes := FBufferSize;
    dscbd.lpwfxFormat := Format;

    if FCapture.CreateCaptureBuffer(dscbd, FBuffer, nil)<>DS_OK then
      raise ESoundCaptureStreamError.CreateFmt(SCannotMade, [SDirectSoundCaptureBuffer]);

    FBufferPos := 0;

    FBuffer.Start(DSCBSTART_LOOPING);

    if Assigned(FOnFilledBuffer) then
    begin
      FNotifyThread := TSoundCaptureStreamNotify.Create(Self);
      FNotifyThread.Resume;
    end;
  except
    Stop;
    raise;
  end;
end;

procedure TSoundCaptureStream.Stop;
begin
  if FCapturing then
  begin
    FNotifyThread.Free;
    FCapturing := False;
    if FBuffer<>nil then
      FBuffer.Stop;
    FBuffer := nil;
  end;
end;


{  TCustomDXSound  }

type
  TDXSoundDirectSound = class(TDirectSound)
  private
    FDXSound: TCustomDXSound;
  protected
    procedure DoRestoreBuffer; override;
  end;

procedure TDXSoundDirectSound.DoRestoreBuffer;
begin
  inherited DoRestoreBuffer;
end;

constructor TCustomDXSound.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FAutoInitialize := True;
  Options := [];
end;

destructor TCustomDXSound.Destroy;
begin
  Finalize;
  inherited Destroy;
end;

procedure TCustomDXSound.FormWndProc(var Message: TMessage; DefWindowProc: TWndMethod);
begin
  case Message.Msg of
    WM_CREATE:
        begin
          DefWindowProc(Message);
          SetForm(FForm);
          Exit;
        end;
  end;
  DefWindowProc(Message);
end;

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

procedure TCustomDXSound.DoFinalize;
begin
  if Assigned(FOnFinalize) then FOnFinalize(Self);
end;

procedure TCustomDXSound.DoInitialize;
begin
  if Assigned(FOnInitialize) then FOnInitialize(Self);
end;

procedure TCustomDXSound.DoInitializing;
begin
  if Assigned(FOnInitializing) then FOnInitializing(Self);
end;

procedure TCustomDXSound.Finalize;
begin
  if FInternalInitialized then
  begin
    try
      FSubClass.Free; FSubClass := nil;

      try
        if FCalledDoInitialize then
        begin
          FCalledDoInitialize := False;
          DoFinalize;
        end;
      finally
      end;
    finally
      FInitialized := False;
      FInternalInitialized := False;

      SetOptions(FOptions);

      FPrimary.Free; FPrimary := nil;
      FDSound.Free;  FDSound := nil;
    end;
  end;
end;

procedure TCustomDXSound.Initialize;
const
  PrimaryDesc: TDSBufferDesc = (
      dwSize: SizeOf (PrimaryDesc);
      dwFlags: DSBCAPS_PRIMARYBUFFER);
var
  Component: TComponent;
begin
  Finalize;

  Component := Owner;
  while (Component<>nil) and (not (Component is TCustomForm)) do
    Component := Component.Owner;

  if Component=nil then raise EDXSoundError.Create(SNoForm);

  DoInitializing;

  FInternalInitialized := True;
  try
    {  DirectSound initialization.  }
    FDSound := TDXSoundDirectSound.Create(Driver);
    TDXSoundDirectSound(FDSound).FDXSound := Self;

    FDSound.FGlobalFocus := soGlobalFocus in FNowOptions;

    {  Primary buffer made.  }
    FPrimary := TDirectSoundBuffer.Create(FDSound);
    if not FPrimary.CreateBuffer(PrimaryDesc) then
      raise EDXSoundError.CreateFmt(SCannotMade, [SDirectSoundPrimaryBuffer]);

    FInitialized := True;

    SetForm(TCustomForm(Component));
  except
    Finalize;
    raise;
  end;

  FCalledDoInitialize := True; DoInitialize;
end;

procedure TCustomDXSound.Loaded;
begin
  inherited Loaded;

  if FAutoInitialize and (not (csDesigning in ComponentState)) then
  begin
    try
      Initialize;
    except
      on E: EDirectSoundError do ;
      else raise;
    end;
  end;
end;

procedure TCustomDXSound.SetDriver(Value: PGUID);
begin
  if not IsBadHugeReadPtr(Value, SizeOf(TGUID)) then
  begin
    FDriverGUID := Value^;
    FDriver := @FDriverGUID;
  end else
    FDriver := Value;
end;

procedure TCustomDXSound.SetForm(Value: TCustomForm);
var
  Level: Integer;
begin
  FForm := Value;

  FSubClass.Free;
  FSubClass := TControlSubClass.Create(FForm, FormWndProc);

  if FInitialized then
  begin
    if soExclusive in FNowOptions then
      Level := DSSCL_EXCLUSIVE
    else
      Level := DSSCL_NORMAL;

    FDSound.DXResult := FDSound.ISound.SetCooperativeLevel(FForm.Handle, Level);
  end;
end;

procedure TCustomDXSound.SetOptions(Value: TDXSoundOptions);
const
  DXSoundOptions = [soGlobalFocus, soStickyFocus, soExclusive];
  InitOptions: TDXSoundOptions = [soExclusive];
var
  OldOptions: TDXSoundOptions;
begin
  FOptions := Value;

  if Initialized then
  begin
    OldOptions := FNowOptions;

    FNowOptions := (FNowOptions - (DXSoundOptions - InitOptions)) +
      (Value - InitOptions);

    FDSound.FGlobalFocus := soGlobalFocus in FNowOptions;
    FDSound.FStickyFocus := soStickyFocus in FNowOptions;
  end else
    FNowOptions := FOptions;
end;

initialization
finalization
  DirectSoundDrivers.Free;
  DirectSoundCaptureDrivers.Free;
end.