Программирование на Delphi

FAQ VCL
Меню

:: Меню ::

:: На главную ::

:: FAQ ::

:: Заметки ::

:: Практика ::

:: Win API ::

:: Проекты ::

:: Скачать ::

:: Секреты ::

:: Ссылки ::

:: Сервис ::

:: Написать ::

:: MVP ::

:: RSS ::

Как прочитать заголовок wav файла?

type
  TWaveHeader = record
    idRiff: array[0..3] of AnsiChar;  // Содержит символы "RIFF" в ASCII кодировке
                                      // ($52494646 в big-endian представлении)
    RiffLen: DWORD;                   // Длина блока данных (длина файла - 8,  то есть,
                                      // исключены поля idRiff и RiffLen)
    idWave: array[0..3] of AnsiChar;  // Содержит символы "WAVE" в ASCII кодировке
                                      // ($57415645 в big-endian представлении)
    idFmt: array[0..3] of AnsiChar;   // Содержит символы "fmt " в ASCII кодировке
                                      // ($666d7420 в big-endian представлении)
    InfoLen: DWORD;                   // Размер блока описания формата (оставшийся
                                      // размер заголовка, начиная с этой позиции,
                                      // т.е. до поля wBitsPerSample включительно)
    AudioFormat: Word;                // Идентификатор формата данных (полный список:
                                      // http://audiocoding.ru/wav_formats.txt)
    NumChannels: Word;                // Количество каналов (1 – моно, 2 – стерео)
    SamplesRate: DWORD;               // Частота дискретизации, Гц
    ByteRate: DWORD;                  // Скорость передачи данных, байт/с (произведение
                                      // числа каналов, частоты дискретизации и
                                      // разрядности в байтах)
    BlockAlign: Word;                 // Количество байт для одного сэмпла (блока)
                                      // (число каналов)*(число байтов на канал)
    BitsPerSample: Word;              // Количество бит в сэмпле. Так называемая "глубина"
                                      // или точность звучания. 8 бит, 16 бит и т.д.
    idData: array[0..3] of AnsiChar;  // Идентификатор области аудиоданных, содержит символы
                                      // "data" в ASCII кодировке
                                      // ($64617461 в big-endian представлении)
    DataSize: Word;                   // Длина области аудиоданных
  end;
 
const
  RIFF = 'RIFF';
  WAVE = 'WAVE';
  FMT  = 'fmt ';
  DATA = 'data';
 
{...}
 
implementation
 
 
function GetWaveHeader( FileName: TFilename ): TWaveHeader;
var
  fs: TFileStream;
begin
   if not FileExists( Filename ) then
      Exit;
 
   try
      fs := TFileStream.Create( FileName, fmOpenRead );
      fs.Read( Result, Sizeof( Result ) );
 
      with Result do
      begin
         if idRiff <> RIFF then
            raise EReadError.Create( 'Wrong idRIFF' );
         if idWave <> WAVE then
            raise EReadError.Create( 'Wrong idWAVE' );
         if idFmt <> FMT then
            raise EReadError.Create( 'Wrong idFmt' );
         if idData <> DATA then
            raise EReadError.Create( 'Wrong idData' );
         // if AudioFormat <> 1 then
         //    raise EReadError.Create( 'Unknown format' );
      end;
   finally
      fs.Free;
   end;
end;
 
procedure TForm1.Button1Click(Sender: TObject);
var
  WaveHeader: TWaveHeader;
begin
   WaveHeader := GetWaveHeader( 'c:\Windows\Media\Afternoon\Windows Ding.wav' );
end;

Как извлечь кадр из видео файла?

// Способ первый
uses
  DirectShow9, ActiveX;
 
/// <param name="FrameTime">Время в секундах
/// <param name="VideoFileName">Путь к файлу
/// <param name="Image">Холст, на который выводится изображение
/// <param name="Stretch">True - вписать в размер холста; False - оригинальный размер
{ Работает не со всеми форматами файлов }
function GetFrame( FrameTime: Double; const VideoFileName: string; Image: TCanvas;
  Stretch: Boolean = False ): HRESULT;
var
  MediaDet: IMediaDet;
  MediaType: TAMMediaType;
  VideoStreams: Integer;
  BufferSize: Integer;
  Buffer: PByte;
  VideoWidth, VideoHeight: Integer;
  BMIHeader: PBitmapInfoHeader;
  BMPInfo: BitmapInfo;
  PData: pointer;
  HDCDest: HDC;
  StreamTime: Double;
  BitmapHdl: HBITMAP;
  NewBitmap: TBitmap;
  FLastErrorMessage: string;
begin
   Result := S_FALSE;
   try
      if CoCreateInstance( CLSID_MediaDet, nil, CLSCTX_INPROC, IMediaDet, MediaDet ) = S_OK then
      begin
         try
            if ( MediaDet.put_Filename( VideoFileName ) = S_OK ) and
               ( MediaDet.get_OutputStreams( VideoStreams ) = S_OK ) and
               ( VideoStreams > 0 ) and
               ( MediaDet.put_CurrentStream( 0 ) = S_OK ) and
               ( MediaDet.get_StreamMediaType( MediaType ) = S_OK ) and
               ( MediaDet.get_StreamLength( StreamTime ) = S_OK ) then
            begin
               if StreamTime >= FrameTime then
                  StreamTime := FrameTime;
               VideoWidth  := PVideoInfoHeader( MediaType.pbFormat )^.bmiHeader.biWidth;
               VideoHeight := PVideoInfoHeader( MediaType.pbFormat )^.bmiHeader.biHeight;
               if Failed( MediaDet.GetBitmapBits( StreamTime, @buffersize, nil, VideoWidth, VideoHeight ) ) then
               begin
                  // FLastErrorMessage := 'GetBitmapBits(StreamTime, @buffersize, nil, VideoWidth, VideoHeight) failed - ' + VideoFileName;
                  Exit;
               end;
               GetMem( Buffer, BufferSize );
               try
                  if Failed( MediaDet.GetBitmapBits( StreamTime, @buffersize, Buffer, VideoWidth, VideoHeight ) ) then
                  begin
                     // FLastErrorMessage := 'GetBitmapBits(StreamTime, @buffersize, Buffer, VideoWidth, VideoHeight) failed - ' + VideoFileName;
                     Exit;
                  end;
                  BMIHeader  := PBitmapInfoHeader( Buffer );
                  Inc( BMIHeader );
                  pData := BMIHeader;
                  BMIHeader := PBitmapInfoHeader( Buffer );
                  ZeroMemory( @BMPInfo, SizeOf( BITMAPINFO ) );
                  CopyMemory( @BMPInfo.bmiHeader, bmiHeader, SizeOf( TBITMAPINFOHEADER ) );
                  HDCDest := GetDC( 0 );
                  if HDCDest = 0 then
                  begin
                     // FLastErrorMessage := 'HDCDest = 0 - ' + VideoFileName;
                     Exit;
                  end;
                  try
                     BitmapHdl := CreateDIBitmap( HDCDest, BMIHeader^, CBM_INIT, pData, BMPInfo, DIB_RGB_COLORS );
                     if BitmapHdl = 0 then
                     begin
                        // FLastErrorMessage := 'CreateDIBitmap failed - ' + VideoFileName;
                        Exit;
                     end
                     else
                     begin
                        NewBitmap := TBitmap.Create;
                        try
                           NewBitmap.Handle := BitmapHdl;
                           if Stretch then
                              Image.StretchDraw( Image.ClipRect, NewBitmap )
                              // Image.CopyRect( Image.ClipRect, NewBitmap.Canvas, NewBitmap.Canvas.ClipRect )
                           else
                              Image.CopyRect( TVideoInfoHeader( MediaType.pbFormat^ ).rcSource,
                                              NewBitmap.Canvas, NewBitmap.Canvas.ClipRect );
                        finally
                           NewBitmap.Free;
                        end;
                     end;
                  finally
                     ReleaseDC( 0, HDCDest );
                  end;
               finally
                  FreeMem( Buffer );
               end;
            end
            else
            begin
               if MediaDet.put_Filename( VideoFileName ) <> S_OK then
                  FLastErrorMessage := 'MediaDet.put_Filename(' + VideoFileName + ') failed.'
               else
               if MediaDet.get_OutputStreams( VideoStreams ) <> S_OK then
                  FLastErrorMessage := 'MediaDet.get_OutputStreams(' + IntToStr( VideoStreams ) + ') failed.'
               else
               if VideoStreams <= 0 then
                  FLastErrorMessage := 'VideoStreams = ' + IntToStr( VideoStreams )
               else
               if MediaDet.put_CurrentStream( 0 ) <> S_OK then
                  FLastErrorMessage := 'MediaDet.put_CurrentStream(0) failed.'
               else
               if MediaDet.get_StreamMediaType( MediaType ) <> S_OK then
                  FLastErrorMessage := 'MediaDet.get_StreamMediaType(MediaType) failed.'
               else
               if MediaDet.get_StreamLength( StreamTime ) <> S_OK then
                  FLastErrorMessage := 'MediaDet.get_StreamLength(StreamTime) failed.'
               else
                  FLastErrorMessage := 'Unknown Error.';
               Exit;
            end;
         finally
            MediaDet := nil;
         end;
      end;
      Result := S_OK;
   except on E: Exception do
      FLastErrorMessage := E.Message;
   end;
end;
 
procedure TForm1.Button1Click(Sender: TObject);
begin
   GetFrame( 173, 'c:\test.mp4', Canvas );
end;
 
// Способ второй
// Смысл кода в том, что для воспроизведения видеофайла нужно создать граф,
// который создается из фильтров. Фильтр - это некий интерфейс, который может
// кодировать, декодировать и воспроизводить видео/аудио. Граф - это правильно
// подобраный набор фильтров для воспроизведения определенного потока и соорудить
// его самому очень сложная задача. Но есть у DirectShow функция RenderFile, которая
// создает граф для вывода в собственное небольшое окно. Это окно удаляется и на его
// место ставится свой граббер.
{ Работает не со всеми форматами файлов }
unit Unit1;
 
interface
 
uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, ExtCtrls, StdCtrls, DirectShow9, ActiveX;
 
type
  TForm1 = class(TForm)
    Button1: TButton;
    Timer1: TTimer;
    procedure Button1Click(Sender: TObject);
    procedure Timer1Timer(Sender: TObject);
  private
    { Private declarations }
    FGraphBuilder: ICaptureGraphBuilder2;
    FFilterGraph: IFilterGraph2;
    FSampleGrabber: ISampleGrabber;
    FMediaPosition: IMediaPosition;
    FBasicAudio: IBasicAudio;
    //video frame
    FAVIWidth: integer;
    FAVIHeight: integer;
    FFrameBitmapInfoHeader: TBitmapInfoHeader;
    FFrameData: array of byte;
    //Bitmap, в который перемещаются кадры видео
    FAVIBitmap: HBITMAP;
    FAVIBitmapDC: HDC;
    FAVIDIBData: Pointer;
    //FAVIDrawDib: HDRAWDIB;
  public
    { Public declarations }
    procedure OpenFile( Path: string );
  end;
 
var
  Form1: TForm1;
 
implementation
 
{$R *.dfm}
 
procedure TForm1.Button1Click(Sender: TObject);
begin
   OpenFile( 'h:\Download\1\A Girl Watcher''s Paradise Vol. 5071.wmv' );
   Timer1.Interval := 10;
   Timer1.Enabled := True;
end;
 
procedure TForm1.OpenFile(Path: string);
 
  procedure Check( Res: HResult );
  begin
     if ( Res <> S_OK ) and ( Res <> VFW_S_PARTIAL_RENDER ) then
        raise Exception.Create( IntToStr( Res ) );
  end;
 
  procedure FindPin( baseFilter: IBaseFilter;
                     direction: PIN_DIRECTION;
                     pinNumber: Integer;
                     out destPin: IPin );
  var
    enumPins: IEnumPins;
    numFound: Cardinal;
    tmpPin: IPin;
    pinDirection: PIN_DIRECTION;
  begin
     destPin := nil;
     if baseFilter.EnumPins( enumPins ) = S_OK then
     begin
        while enumPins.Next( 1, tmpPin, @numFound ) = S_OK do
        begin
           tmpPin.QueryDirection( pinDirection );
           if pinDirection = direction then
           begin
              if pinNumber = 0 then
              begin
                 // Return the pin's interface
                 destPin := tmpPin;
                 Break;
              end
              else
                 DestPin := nil;
              Dec( pinNumber );
           end;
           tmpPin := nil;
        end;
     end;
  end;
 
  function ConnectPins( outputFilter: IBaseFilter;
                        outputNum: Cardinal;
                        inputFilter: IBaseFilter;
                        inputNum: Cardinal ): Boolean;
  var
    inputPin, outputPin: IPin;
  begin
     if ( outputFilter = nil ) or ( inputFilter = nil ) then
     begin
        Result := False;
        Exit;
     end;
     FindPin( outputFilter, PINDIR_OUTPUT, outputNum, outputPin );
     FindPin( inputFilter, PINDIR_INPUT, inputNum, inputPin );
     if ( outputPin = nil ) or ( InputPin = nil ) then
        Check( -1 );
     Check( FFilterGraph.Connect( outputPin, inputPin ) );
     Result := True;
  end;
 
const
  MaxGraphRunAttempts = 100;
 
var
  bmi: BITMAPINFO;
  BitmapHeader: BITMAPINFOHEADER;
  WideStr: WideString;
  RunGraphAttempts: Integer;
  grabberFilter, nullRenderer: IBaseFilter;
  desiredType, connectedType: AM_MEDIA_TYPE;
  infoHeader: VIDEOINFOHEADER;
  mediaControl: IMediaControl;
  pfs: _FilterState;
  BufSize: Integer;
  OutputPin, inputPin: IPin;
  EnumFilters: IEnumFilters;
  VideoRenderer, TmpFilter: IBaseFilter;
  TmpGUID: TGUID;
begin
   // Create the main object that runs the graph
   Check( CoCreateInstance( CLSID_CaptureGraphBuilder2, nil, CLSCTX_INPROC_SERVER,
          IID_ICaptureGraphBuilder2, FGraphBuilder ) );
   // Create filter graph
   Check( CoCreateInstance( CLSID_FilterGraph, nil, CLSCTX_INPROC_SERVER,
          IID_IFilterGraph, FFilterGraph ) );
   // Convert file name to unicode
   WideStr := Path;
   // Render whole graph
   Check( FFilterGraph.RenderFile( PWideChar( WideStr ), nil ) );
   // Seeking for default renderer window
   VideoRenderer := nil;
   FFilterGraph.EnumFilters( EnumFilters );
   while EnumFilters.Next( 1, TmpFilter, @BufSize ) = S_OK do
   begin
      if TmpFilter.GetClassID( TmpGUID ) = S_OK then
      begin
         if IsEqualGUID( TmpGUID, CLSID_VideoMixingRenderer ) or
            IsEqualGUID( TmpGUID, CLSID_VideoRendererDefault ) then
         begin
            VideoRenderer := TmpFilter;
            Break;
         end;
      end;
   end;
   if VideoRenderer = nil then
      raise Exception.Create( 'No video decoders found' );
   // Find video output pin and disconnect default video renderer
   FindPin( VideoRenderer, PINDIR_INPUT, 0, inputPin );
   Check( inputPin.ConnectedTo( OutputPin ) );
   FFilterGraph.RemoveFilter( VideoRenderer );
   // Create the Sample Grabber to take frames
   Check( CoCreateInstance( CLSID_SampleGrabber, nil, CLSCTX_INPROC_SERVER,
          IID_IBaseFilter, GrabberFilter ) );
   Check( grabberFilter.QueryInterface( IID_ISampleGrabber, FSampleGrabber ) );
   Check( FFilterGraph.AddFilter( grabberFilter, 'Sample Grabber' ) );
   // Set the 24-bit RGB desire here
   // So that the proper conversion filters
   // Are added automatically.
   FillMemory( @DesiredType, Sizeof( desiredType ), 0 );
   desiredType.majortype := MEDIATYPE_Video;
   desiredType.subtype := MEDIASUBTYPE_RGB24;
   desiredType.formattype := FORMAT_VideoInfo;
   Check( FSampleGrabber.SetMediaType( desiredType ) );
   Check( FSampleGrabber.SetBufferSamples( True ) );
   // Connect grabber to video output
   FindPin( grabberFilter, PINDIR_INPUT, 0, inputPin );
   Check( FFilterGraph.Connect( OutputPin, inputPin ) );
   // A Null Renderer does not display the video
   // But it allows the Sample Grabber to run
   // And it will keep proper playback timing
   // Unless specified otherwise.
   Check( CoCreateInstance( CLSID_NullRenderer, nil, CLSCTX_INPROC_SERVER,
          IID_IBaseFilter, nullRenderer ) );
   Check( FFilterGraph.AddFilter( nullRenderer, 'New Null Renderer' ) );
   ConnectPins( grabberFilter, 0, nullRenderer, 0 );
   // Video resolution
   Check( FSampleGrabber.GetConnectedMediaType( connectedType ) );
   if not IsEqualGUID( connectedType.formattype, FORMAT_VideoInfo ) then
      raise Exception.Create( 'Cannot get video info' );
   infoHeader := VIDEOINFOHEADER( connectedType.pbFormat^ );
   FAVIWidth := infoHeader.bmiHeader.biWidth;
   FAVIHeight := infoHeader.bmiHeader.biHeight;
   FFrameBitmapInfoHeader := infoHeader.bmiHeader;
   CoTaskMemFree( connectedType.pbFormat );
   Check( FFilterGraph.QueryInterface( IID_IMediaControl, MediaControl ) );
   // Tell the whole graph to start sending video
   if mediaControl.Run <> S_OK then
   begin
      RunGraphAttempts := 0;
      while mediaControl.GetState( 100, pfs ) <> S_OK do
      begin
         Sleep( 100 );
         Inc( RunGraphAttempts );
         if RunGraphAttempts > MaxGraphRunAttempts then
            raise Exception.Create( 'Cannot play graph' );
      end;
   end;
   ZeroMemory( @bmi, SizeOf( bmi ) );
   ZeroMemory( @BitmapHeader, SizeOf( BitmapHeader ) );
   with bmi.bmiHeader do
   begin
      biSize := SizeOf( BITMAPINFOHEADER );
      biPlanes := 1;
      biBitCount := 24;
      biWidth := FAVIWidth;
      biHeight := FAVIHeight;
      biCompression := BI_RGB;
   end;
   FAVIBitmapDC := CreateCompatibleDC( 0 );
   FAVIBitmap := CreateDIBSection( FAVIBitmapDC, bmi, DIB_RGB_COLORS, FAVIDIBData, 0, 0 );
   SelectObject( FAVIBitmapDC, FAVIBitmap );
end;
 
procedure TForm1.Timer1Timer(Sender: TObject);
var
  ErrCode, DibDataSize: Integer;
begin
   if FSampleGrabber = nil then
      Exit;
   FSampleGrabber.GetCurrentBuffer( DibDataSize, nil );
   Assert( DibDataSize = FAVIWidth * FAVIHEight * 3 );
   ErrCode := FSampleGrabber.GetCurrentBuffer( DibDataSize, FAVIDIBData );
   StretchBlt( Canvas.Handle, 0, 0, FAVIWidth, FAVIHEight, FAVIBitmapDC, 0, 0,
               FAVIWidth, FAVIHeight, SRCCOPY );
end;
 
end.

Как определить что в приводе находится Audio CD?

function IsAudioCD( Drive: Char ): BOOL;
var
  DrivePath: string;
  MaximumComponentLength: DWORD;
  FileSystemFlags: DWORD;
  VolumeName: string;
begin
   Result := False;
   DrivePath := Drive + ':\';
   if GetDriveType( PChar( DrivePath ) ) = DRIVE_CDROM then
   begin
      SetLength( VolumeName, 64 );
      GetVolumeInformation( PChar( DrivePath ), PChar( VolumeName ), Length( VolumeName ),
                            nil, MaximumComponentLength, FileSystemFlags, nil, 0 );
      if lStrCmp( PChar( VolumeName ), 'Audio CD' ) = 0 then
         Result := True;
   end;
end;
 
procedure TForm1.Button1Click(Sender: TObject);
begin
   if IsAudioCD( 'E' ) then
      ShowMessage( 'Cd is an audio cd' )
   else
      ShowMessage( 'Cd is not an audio cd' );
end;

Как получить информацию о дорожках Audio CD?

uses
  {...,} MMSystem;
 
procedure TForm1.Button1Click(Sender: TObject);
type
  TDWord = record
    High: Word;
    Low: Word;
  end;
var
  msp: TMCI_INFO_PARMS;
  MediaString: array[0..255] of Char;
  ret: LongInt;
  i: integer;
  StatusParms: TMCI_STATUS_PARMS;
  MciSetParms: TMCI_SET_PARMS;
  MciOpenParms: TMCI_OPEN_PARMS;
  aDeviceID: MCIDEVICEID;
 
  function GetTheDeviceID: MCIDEVICEID;
  begin
     FillChar( MciOpenParms, SizeOf( MciOpenParms ), #0 );
     try
        MciOpenParms.lpstrDeviceType := 'cdaudio';
        ret := mciSendCommand( 0, MCI_OPEN, MCI_OPEN_TYPE + MCI_OPEN_SHAREABLE,
                               LongInt( @MciOpenParms ) );
        Result := MciOpenParms.wDeviceID;
     except
        on E: Exception do
        begin
           Result := 0;
           ShowMessage( 'Error receiving deviceIDt' + #13 +
                        SysErrorMessage( GetLastError ) + #13 + E.Message );
        end;
     end;
  end;
 
  function GetTrackInfo( const uMsg: UInt; const fdwCommand: DWord;
    const dwItem: DWord; const dwTrack: DWord ): string;
  begin
     Result := 'Did not work...';
     FillChar( MediaString, SizeOf( MediaString ), #0 );
     FillChar( StatusParms, SizeOf( StatusParms ), #0 );
     StatusParms.dwItem := dwItem;
     StatusParms.dwTrack := dwTrack;
     ret := mciSendCommand( aDeviceID, uMsg, fdwCommand, Longint( @StatusParms ) );
     if Ret = 0 then
        Result := IntToStr( StatusParms.dwReturn );
  end;
 
  procedure SetTimeInfo;
  begin
     FillChar( MciSetParms, SizeOf( MciSetParms ), #0 );
     MciSetParms.dwTimeFormat := MCI_FORMAT_MSF;
     ret := mciSendCommand( aDeviceID {Mp.DeviceId}, MCI_SET, MCI_SET_TIME_FORMAT,
            Longint( @MciSetParms ) );
     if ret <> 0 then
        ShowMessage( 'Error convering timeformat...' );
  end;
 
begin
   Memo1.Clear;
   aDeviceID := GetTheDeviceID;
   Application.ProcessMessages;
   Memo1.Lines.Add( 'Track info:' );
   SetTimeInfo;
   Memo1.Lines.Add( 'Tracks: ' + GetTrackInfo( MCI_STATUS, MCI_STATUS_ITEM,
                    MCI_STATUS_NUMBER_OF_TRACKS, 0 ) );
   Memo1.Lines.Add( '' );
   for i := 1 to StrToInt( GetTrackInfo( MCI_STATUS, MCI_STATUS_ITEM,
      MCI_STATUS_NUMBER_OF_TRACKS, 0 ) ) do
   begin
      Memo1.Lines.Add( 'Track ' + IntToStr( i ) + ':   ' + IntToStr( MCI_MSF_MINUTE
                       ( StrToInt( GetTrackInfo( MCI_STATUS, MCI_STATUS_ITEM +
                       MCI_TRACK, MCI_STATUS_LENGTH, i ) ) ) ) + ':' +
                       IntToStr( MCI_MSF_SECOND( StrToInt( GetTrackInfo( MCI_STATUS,
                       MCI_STATUS_ITEM + MCI_TRACK, MCI_STATUS_LENGTH, i ) ) ) ) );
   end;
end;

Как получить список установленных устройств видеозахвата (веб-камер)?

uses
  {...,} ActiveX, ComObj, DirectShow9;
 
procedure EnumerateVideoInputDevices(Memo: TMemo);
const
  IID_IPropertyBag: TGUID = '{55272A00-42CB-11CE-8135-00AA004BB851}';
var
  LDevEnum : ICreateDevEnum;
  ppEnumMoniker: IEnumMoniker;
  pceltFetched: ULONG;
  Moniker: IMoniker;
  PropBag: IPropertyBag;
  pvar: OleVariant;
  hr: HRESULT;
  i: Integer;
begin
  CocreateInstance(CLSID_SystemDeviceEnum, nil, CLSCTX_INPROC, IID_ICreateDevEnum, LDevEnum);
  hr := LDevEnum.CreateClassEnumerator(CLSID_VideoInputDeviceCategory, ppEnumMoniker, 0);
  if hr = S_OK then
    while ppEnumMoniker.Next(1, Moniker, @pceltFetched) = S_OK do
    begin
      Moniker.BindToStorage(nil, nil, IID_IPropertyBag, PropBag);
      if PropBag.Read('Description', pvar, nil) = S_OK then
      begin
        Memo.Lines.Add('Description:');
        Memo.Lines.Add(Format('      %s', [string(pvar)]));
      end;
      if PropBag.Read('FriendlyName', pvar, nil) = S_OK then
      begin
        Memo.Lines.Add('Friendly Name:');
        Memo.Lines.Add(Format('      %s', [string(pvar)]));
      end;
      if PropBag.Read('DevicePath', pvar, nil) = S_OK then
      begin
        Memo.Lines.Add('Device  Path:');
        Memo.Lines.Add(Format('      %s', [string(pvar)]));
      end;
      if PropBag.Read('CLSID', pvar, nil) = S_OK then
      begin
        Memo.Lines.Add('CLSID:');
        Memo.Lines.Add(Format('      %s', [string(pvar)]));
      end;
      Memo.Lines.Add('---------------------------');
      PropBag := nil;
      Moniker := nil;
    end;
  ppEnumMoniker := nil;
  LDevEnum := nil;
end;
 
procedure TForm1.Button1Click(Sender: TObject);
begin
  EnumerateVideoInputDevices(Memo1);
end;

Как получить список установленных устройств аудиозахвата?

uses
  {...,} ActiveX, ComObj, DirectShow9;
 
procedure EnumerateAudioInputDevices(Memo: TMemo);
const
  IID_IPropertyBag: TGUID = '{55272A00-42CB-11CE-8135-00AA004BB851}';
var
  LDevEnum : ICreateDevEnum;
  ppEnumMoniker: IEnumMoniker;
  pceltFetched: ULONG;
  Moniker: IMoniker;
  PropBag: IPropertyBag;
  pvar: OleVariant;
  hr: HRESULT;
  i: Integer;
begin
  CocreateInstance(CLSID_SystemDeviceEnum, nil, CLSCTX_INPROC, IID_ICreateDevEnum, LDevEnum);
  hr := LDevEnum.CreateClassEnumerator(CLSID_AudioInputDeviceCategory, ppEnumMoniker, 0);
  if hr = S_OK then
    while ppEnumMoniker.Next(1, Moniker, @pceltFetched) = S_OK do
    begin
      Moniker.BindToStorage(nil, nil, IID_IPropertyBag, PropBag);
      if PropBag.Read('Description', pvar, nil) = S_OK then
      begin
        Memo.Lines.Add('Description:');
        Memo.Lines.Add(Format('      %s', [string(pvar)]));
      end;
      if PropBag.Read('FriendlyName', pvar, nil) = S_OK then
      begin
        Memo.Lines.Add('Friendly Name:');
        Memo.Lines.Add(Format('      %s', [string(pvar)]));
      end;
      if PropBag.Read('CLSID', pvar, nil) = S_OK then
      begin
        Memo.Lines.Add('CLSID:');
        Memo.Lines.Add(Format('      %s', [string(pvar)]));
      end;
      Memo.Lines.Add('---------------------------');
      PropBag := nil;
      Moniker := nil;
    end;
  ppEnumMoniker := nil;
  LDevEnum := nil;
end;
 
procedure TForm1.Button1Click(Sender: TObject);
begin
  EnumerateAudioInputDevices(Memo1);
end;

При использовании материала - ссылка на сайт обязательна