mmdscapt.pas

一套及时通讯的原码

      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.