unit Unit2;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, ExtCtrls, directshow9, ActiveX, jpeg;

type
  TForm2 = class(TForm)
    Button1: TButton;
    ListBox1: TListBox;
    Panel1: TPanel;
    Button2: TButton;
    ListBox2: TListBox;
    Button3: TButton;
    Button4: TButton;
    Button5: TButton;
    SaveDialog1: TSaveDialog;
    Panel2: TPanel;
    function CreateGraph: HResult;
    function Initializ: HResult;
//    function CaptureBitmap: HResult;
    procedure Button1Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure Button3Click(Sender: TObject);
    function  DisplayPropertyFrame(Filter: IBaseFilter; Handle: THandle): HResult;
    procedure Button4Click(Sender: TObject);
    procedure Button5Click(Sender: TObject);
    procedure ListBox1DblClick(Sender: TObject);
    procedure ListBox2DblClick(Sender: TObject);

  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form2: TForm2;
  FileName:string; //имя файла для записи
  RecMode: Boolean = False; //флаг записи
  DeviceName:OleVariant;  //имя устройства
  PropertyName:IPropertyBag; //
  pDevEnum:ICreateDEvEnum; //перечислитель устройств
  pEnum:IEnumMoniker; //перечислитель моникеров
  pMoniker:IMoniker;

  MArray1,MArray2: array of IMoniker; //Это список моникеров, из которго
                                      //мы потом будем получать необходмый моникер


//интерфейсы
    FGraphBuilder:        IGraphBuilder;
    FCaptureGraphBuilder: ICaptureGraphBuilder2;
    FMux:                 IBaseFilter;
    FSink:                IFileSinkFilter;
    FMediaControl:        IMediaControl;
    FVideoWindow:         IVideoWindow;

    FVideoCaptureFilter:  IBaseFilter;
    FAudioCaptureFilter:  IBaseFilter;
//область вывода изображения
    FVideoRect:           TRect;
      FBaseFilter:          IBaseFilter;
    FSampleGrabber:       ISampleGrabber;
    MediaType:            AM_MEDIA_TYPE;

implementation

{$R *.dfm}

function TForm2.Initializ: HResult;
begin
//Создаем объект для перечисления устройств
Result:=CoCreateInstance(CLSID_SystemDeviceEnum, NIL, CLSCTX_INPROC_SERVER,
IID_ICreateDevEnum, pDevEnum);
if Result<>S_OK then EXIT;

//Перечислитель устройств Video
Result:=pDevEnum.CreateClassEnumerator(CLSID_VideoInputDeviceCategory, pEnum, 0);
if Result<>S_OK then EXIT;
//Обнуляем массив в списке моникеров
setlength(MArray1,0);
//Пускаем массив по списку устройств
while (S_OK=pEnum.Next(1,pMoniker,Nil)) do
begin
setlength(MArray1,length(MArray1)+1); //Увеличиваем массив на единицу
MArray1[length(MArray1)-1]:=pMoniker; //Запоминаем моникер в масиве
Result:=pMoniker.BindToStorage(NIL, NIL, IPropertyBag, PropertyName); //Линкуем моникер устройства к формату хранения IPropertyBag
if FAILED(Result) then Continue;
Result:=PropertyName.Read('FriendlyName', DeviceName, NIL); //Получаем имя устройства
if FAILED(Result) then Continue;
//Добавляем имя устройства в списки
Listbox1.Items.Add(DeviceName);
end;

//Перечислитель устройств Audio
Result:=pDevEnum.CreateClassEnumerator(CLSID_AudioInputDeviceCategory, pEnum, 0);
if Result<>S_OK  then EXIT;
//Обнуляем массив в списке моникеров
setlength(MArray2,0);
//Пускаем массив по списку устройств
while (S_OK=pEnum.Next(1,pMoniker,Nil)) do
begin
setlength(MArray2,length(MArray2)+1); //Увеличиваем массив на единицу
MArray2[length(MArray2)-1]:=pMoniker; //Запоминаем моникер в масиве
Result:=pMoniker.BindToStorage(NIL, NIL, IPropertyBag, PropertyName); //Линкуем моникер устройства к формату хранения IPropertyBag
if FAILED(Result) then Continue;
Result:=PropertyName.Read('FriendlyName', DeviceName, NIL); //Получаем имя устройства
if FAILED(Result) then Continue;
//Добавляем имя устройства в списки
Listbox2.Items.Add(DeviceName);
end;
//Первоначальный выбор устройств для захвата видео и звука
//Выбираем из спика камеру
if ListBox1.Count=0 then
   begin
      ShowMessage('Камера не знайдена');
      Result:=E_FAIL;;
      Exit;
   end;
Listbox1.ItemIndex:=0;
//Выбираем из спика устройства для записи звука
if ListBox2.Count=0 then
    begin
      ShowMessage('Мікрофон не знайдений');
    end
                    else  Listbox2.ItemIndex:=0;

//если все ОК
Result:=S_OK;
end;

function TForm2.CreateGraph:HResult;
var
  pConfigMux: IConfigAviMux;
begin
//Чистим граф
  FAudioCaptureFilter  := NIL;
  FVideoCaptureFilter  := NIL;
  FVideoWindow         := NIL;
  FMediaControl        := NIL;
  FSink                := NIL;
  FMux                 := NIL;
  FCaptureGraphBuilder := NIL;
  FGraphBuilder        := NIL;

//Создаем объект для графа фильтров
Result:=CoCreateInstance(CLSID_FilterGraph, NIL, CLSCTX_INPROC_SERVER, IID_IGraphBuilder, FGraphBuilder);
if FAILED(Result) then EXIT;
//Создаем объект для графа захвата
Result:=CoCreateInstance(CLSID_CaptureGraphBuilder2, NIL, CLSCTX_INPROC_SERVER, IID_ICaptureGraphBuilder2, FCaptureGraphBuilder);
if FAILED(Result) then EXIT;
//Задаем граф фильтров
Result:=FCaptureGraphBuilder.SetFiltergraph(FGraphBuilder);
if FAILED(Result) then EXIT;

//выбор устройств ListBox - ов
if Listbox1.ItemIndex>=0 then
           begin
              //получаем устройство для захвата видео из списка моникеров
              MArray1[Listbox1.ItemIndex].BindToObject(NIL, NIL, IID_IBaseFilter, FVideoCaptureFilter);
              //добавляем устройство в граф фильтров
              FGraphBuilder.AddFilter(FVideoCaptureFilter, 'VideoCaptureFilter'); //Получаем фильтр графа захвата
           end;

//если выбрано устройство для захвата звука
if Listbox2.ItemIndex>=0 then
           begin
              //получаем устройство для захвата звука из списка моникеров
              MArray2[Listbox2.ItemIndex].BindToObject(NIL, NIL, IID_IBaseFilter, FAudioCaptureFilter);
              //добавляем устройство в граф фильтров
              FGraphBuilder.AddFilter(FAudioCaptureFilter, 'AudioCaptureFilter');
              //строим граф для вывода звука
              Result:=FCaptureGraphBuilder.RenderStream(@PIN_CATEGORY_PREVIEW, @MEDIATYPE_Audio,
              FAudioCaptureFilter, NIL, NIL);
              if FAILED(Result) then EXIT;
           end;

//строим граф для вывода изображения
Result:=FCaptureGraphBuilder.RenderStream(@PIN_CATEGORY_PREVIEW, @MEDIATYPE_Video, FVideoCaptureFilter, NIL, NIL);
if FAILED(Result) then EXIT;

//Получаем интерфейс управления окном видео
Result:=FGraphBuilder.QueryInterface(IID_IVideoWindow, FVideoWindow);
if FAILED(Result) then EXIT;
//Задаем стиль окна вывода
FVideoWindow.put_WindowStyle(WS_CHILD or WS_CLIPSIBLINGS);
//Накладываем окно вывода на  Panel1
FVideoWindow.put_Owner(Panel1.Handle);
//Задаем размеры окна во всю панель
FVideoRect:=Panel1.ClientRect;
FVideoWindow.SetWindowPosition(FVideoRect.Left,FVideoRect.Top, FVideoRect.Right - FVideoRect.Left,FVideoRect.Bottom - FVideoRect.Top);
//показываем окно
FVideoWindow.put_Visible(TRUE);

//Запись
if RecMode then
begin
//Создаем файл для записи данных из графа
Result:=FCaptureGraphBuilder.SetOutputFileName(MEDIASUBTYPE_Avi, PWideChar(FileName), FMux, FSink);
if FAILED(Result) then EXIT;

//строим граф фильтров для захвата изображения
Result:=FCaptureGraphBuilder.RenderStream(@PIN_CATEGORY_CAPTURE, @MEDIATYPE_Video, FVideoCaptureFilter, Nil, FMux);
if FAILED(Result) then EXIT;


if Listbox2.ItemIndex>=0 then
    begin
        //строим граф фильтров для захвата звука
        Result:=FCaptureGraphBuilder.RenderStream(@PIN_CATEGORY_CAPTURE, @MEDIATYPE_Audio, FAudioCaptureFilter, Nil, FMux);
        if FAILED(Result) then EXIT;
        // При захвате видео со звуком устанавливаем звуковой поток в
        // качестве основного для синхронизации с другими потоками в файле
                pConfigMux := NIL;
                Result:=FMux.QueryInterface(IID_IConfigAviMux, pConfigMux);
                if FAILED(Result) then EXIT;
                begin
                  pConfigMux.SetMasterStream(1);
                  pConfigMux := NIL;
                end;
    end;
end;
//Запрашиваем интерфейс управления графом
Result:=FGraphBuilder.QueryInterface(IID_IMediaControl, FMediaControl);
if FAILED(Result) then Exit;
//Запускаем отображение просмотра с вебкамер
FMediaControl.Run();
//end;
  if FSampleGrabber <> NIL then
  begin
    //обнуляем память
    ZeroMemory(@MediaType, sizeof(AM_MEDIA_TYPE));
    // Устанавливаем формат данных для фильтра перехвата
    with MediaType do
    begin
      majortype  := MEDIATYPE_Video;
      subtype    := MEDIASUBTYPE_RGB24;
      formattype := FORMAT_VideoInfo;
    end;

    FSampleGrabber.SetMediaType(MediaType);

    // Данные будут записаны в буфер в том виде, в котором они
    // проходят через фильтр
    FSampleGrabber.SetBufferSamples(TRUE);

    // Граф не будет остановлен для получения кадра
    FSampleGrabber.SetOneShot(FALSE);
  end;

//Задаем граф фильтров
Result:=FCaptureGraphBuilder.SetFiltergraph(FGraphBuilder);
if FAILED(Result) then EXIT;

//выбор устройств ListBox - ов
if Listbox1.ItemIndex>=0 then
           begin
              //получаем устройство для захвата видео из списка моникеров
              MArray1[Listbox1.ItemIndex].BindToObject(NIL, NIL, IID_IBaseFilter, FVideoCaptureFilter);
              //добавляем устройство в граф фильтров
              FGraphBuilder.AddFilter(FVideoCaptureFilter, 'VideoCaptureFilter'); //Получаем фильтр графа захвата
           end;

//Задаем, что откуда будем получать и куда оно должно выводиться
Result:=FCaptureGraphBuilder.RenderStream(@PIN_CATEGORY_PREVIEW, nil, FVideoCaptureFilter ,FBaseFilter  ,nil);
if FAILED(Result) then EXIT;

//Получаем интерфейс управления окном видео
Result:=FGraphBuilder.QueryInterface(IID_IVideoWindow, FVideoWindow);
if FAILED(Result) then EXIT;
//Задаем стиль окна вывода
FVideoWindow.put_WindowStyle(WS_CHILD or WS_CLIPSIBLINGS);
//Накладываем окно вывода на  Panel1
FVideoWindow.put_Owner(Panel1.Handle);
//Задаем размеры окна во всю панель
FVideoRect:=Panel1.ClientRect;
FVideoWindow.SetWindowPosition(FVideoRect.Left,FVideoRect.Top, FVideoRect.Right - FVideoRect.Left,FVideoRect.Bottom - FVideoRect.Top);
//показываем окно
FVideoWindow.put_Visible(TRUE);

//Запрашиваем интерфейс управления графом
Result:=FGraphBuilder.QueryInterface(IID_IMediaControl, FMediaControl);
if FAILED(Result) then Exit;
//Запускаем отображение просмотра с вебкамер
FMediaControl.Run();
end;



//Запись с камеры в файл
procedure TForm2.Button1Click(Sender: TObject);
begin
//проверяем если устройства для захвата Video
if Listbox1.Count=0 then
    Begin
      ShowMessage('Камера не знайдена');
      Exit;
    End;
//если запись уже идет, то выходим
If RecMode then Exit;
//задаем текущий каталог для записи
SaveDialog1.InitialDir:=GetCurrentDir;
// Установка расширения по умолчанию
SaveDialog1.DefaultExt := 'avi';
if not (SaveDialog1.Execute) then  exit;
//получаем имя файла для записи
FileName:=SaveDialog1.FileName;
//устанавливаем флаг записи
RecMode:=True;
//вызываем процедуру построения графа фильтров
if FAILED(CreateGraph) then
    Begin
      ShowMessage('Виникла помилка при побудові графа фільтрів');
      RecMode:=False;
      Exit;
    End;
//Выводим на панель надпись
Panel2.Caption:='Йде запис відео';
end;

//Остановка записи и переход в режим просмотра
procedure TForm2.Button2Click(Sender: TObject);
begin
//если запись не идет, то выходим
If not(RecMode) then Exit;
// Останавливаем работу графа
FMediaControl.Stop;
//устанавливаем флаг записи
RecMode:=False;
//перестраиваем граф
if FAILED(CreateGraph) then
    Begin
      ShowMessage('Виникла помилка при побудові графа фільтрів');
      Exit;
    End;
Panel2.Caption:='Режим перегляду';
end;

procedure TForm2.Button3Click(Sender: TObject);
//Вызов страницы свойств Web-камеры
var
  StreamConfig: IAMStreamConfig;
  PropertyPages: ISpecifyPropertyPages;
  Pages: CAUUID;
begin
//если запись уже идет - выходим
If RecMode then Exit;
  // Если отсутствует интерфейс работы с видео, то завершаем работу
  if FVideoCaptureFilter = NIL then EXIT;
  // Останавливаем работу графа
  FMediaControl.Stop;
  try
    // Ищем интерфейс управления форматом данных выходного потока
    // Если интерфейс найден, то ...
    if SUCCEEDED(FCaptureGraphBuilder.FindInterface(@PIN_CATEGORY_CAPTURE,
      @MEDIATYPE_Video, FVideoCaptureFilter, IID_IAMStreamConfig, StreamConfig)) then
    begin
      // ... пытаемся найти интерфейс управления страницами свойств ...
      // ... и, если он найден, то ...
      if SUCCEEDED(StreamConfig.QueryInterface(ISpecifyPropertyPages, PropertyPages)) then
      begin
        // ... получаем массив страниц свойств
        PropertyPages.GetPages(Pages);
        PropertyPages := NIL;

        // Отображаем страницу свойств в виде модального диалога
        OleCreatePropertyFrame(
           Handle,
           0,
           0,
           PWideChar(ListBox1.Items.Strings[listbox1.ItemIndex]),
           1,
           @StreamConfig,
           Pages.cElems,
           Pages.pElems,
           0,
           0,
           NIL
        );

        // Освобождаем память
        StreamConfig := NIL;
        CoTaskMemFree(Pages.pElems);
      end;
    end;

  finally
    // Восстанавливаем работу графа
    FMediaControl.Run;
  end;
end;



//Вызов страницы свойств заданного фильтра
function TForm2.DisplayPropertyFrame(Filter: IBaseFilter; Handle: THandle): HResult;
var
  PropertyPages: ISpecifyPropertyPages;
  Pages: CAUUID;
  FilterInfo: TFilterInfo;
  pfilterUnk: IUnknown;
begin
  // Результат по умолчанию
  Result := E_FAIL;

  // Если фильтр не определен, то завершаем работу
  if Filter = NIL then EXIT;

  // Пытаемся найти интерфейс управления страницами свойств фильтра
  Result := Filter.QueryInterface(ISpecifyPropertyPages, PropertyPages);

  if (SUCCEEDED(Result)) then
  begin
    // Получение имени фильтра и указателя на интерфейс IUnknown
    Filter.QueryFilterInfo(FilterInfo);
    Filter.QueryInterface(IUnknown, pfilterUnk);

    // Получаем массив страниц свойств
    PropertyPages.GetPages(Pages);
    PropertyPages := NIL;

    // Отображаем страницу свойств в виде модального диалога
    OleCreatePropertyFrame(
       Handle,
       0,
       0,
       FilterInfo.achName,
       1,
       @pfilterUnk,
       Pages.cElems,
       Pages.pElems,
       0,
       0,
       NIL
    );

    // Освобождаем память
    pfilterUnk := NIL;
    FilterInfo.pGraph := NIL;
    CoTaskMemFree(Pages.pElems);
  end;

end;

//Вызов страницы свойств устройства работы с видео
procedure TForm2.Button4Click(Sender: TObject);
begin
If RecMode then Exit;
DisplayPropertyFrame(FVideoCaptureFilter, Handle);
end;

//Вызов страницы свойств устройства работы со звуком
procedure TForm2.Button5Click(Sender: TObject);
begin
If RecMode then Exit;
DisplayPropertyFrame(FAudioCaptureFilter, Handle);
end;


procedure TForm2.FormCreate(Sender: TObject);
begin
CoInitialize(nil);// инициализировать OLE COM
//вызываем процедуру поиска и инициализации устройств захвата видео и звука
if FAILED(Initializ) then
    Begin
      ShowMessage('Внимание! Произошла ошибка при инициализации');
      Exit;
    End;
//проверяем найденный список устройств
if Listbox1.Count>0 then
    Begin
        //если необходимые для работы устройства найдены,
        //то вызываем процедуру построения графа фильтров
        if FAILED(CreateGraph) then
            Begin
              ShowMessage('Виникла помилка при побудові графа фільтрів');
              Exit;
            End;
        Panel2.Caption:='Режим перегляду';
    end else
            Begin
              ShowMessage('Камери не знайдено');
              //Application.Terminate;
            End;
end;

procedure TForm2.FormDestroy(Sender: TObject);
begin
// Освобождаем память
        pEnum := NIL;
        pDevEnum := NIL;
        pMoniker := NIL;
        PropertyName := NIL;
        DeviceName:=Unassigned;
        CoUninitialize;// деинициализировать OLE COM
end;


//Выбор устройств из ListBox1
procedure TForm2.ListBox1DblClick(Sender: TObject);
begin
if ListBox1.Count=0 then
    Begin
       ShowMessage('Камери не знайдено');
       Exit;
    End;
//перестраиваем  граф при смене камеры
if FAILED(CreateGraph) then
    Begin
      ShowMessage('Виникла помилка при побудові графа фільтрів');
      Exit;
    End;
Panel2.Caption:='Режим перегляду';
end;

//Выбор устройств из ListBox2
procedure TForm2.ListBox2DblClick(Sender: TObject);
begin
if ListBox1.Count>0 then
    begin
    //перестраиваем граф при смене устройства захвата звука
      if FAILED(CreateGraph) then
            Begin
              ShowMessage('Виникла помилка при побудові графа фільтрів');
              Exit;
            End;
Panel2.Caption:='Режим перегляду';
     end else
            Begin
               ShowMessage('Не вибрана камера');
               Exit;
            End;
end;


end.