Форум программистов
 

Восстановите пароль или Зарегистрируйтесь на форуме, о проблемах и с заказом рекламы пишите сюда - alarforum@yandex.ru, проверяйте папку спам!

Вернуться   Форум программистов > Delphi программирование > Общие вопросы Delphi
Регистрация

Восстановить пароль
Повторная активизация e-mail

Купить рекламу на форуме - 42 тыс руб за месяц

Ответ
 
Опции темы Поиск в этой теме
Старый 30.10.2016, 21:42   #11
alman12
Форумчанин
 
Регистрация: 30.12.2013
Сообщений: 466
По умолчанию

какая разница чей код в интернете везде есть этот код
alman12 вне форума Ответить с цитированием
Старый 30.10.2016, 22:56   #12
Pavia
Лис
Старожил
 
Аватар для Pavia
 
Регистрация: 18.09.2015
Сообщений: 2,409
По умолчанию

alman12
В вашем коде отсутствует порождение микшета VMR и его присоединения к графу.
Добавте в конце функции Initializ следующие строки

Код:
{ ВКЛИНИВАЕМСЯ В ГРАФ }
//--- VMR
  if failed(CoCreateInstance(CLSID_VideoMixingRenderer,
            nil, CLSCTX_INPROC_SERVER,
            IID_IBaseFilter,pRenderer)) then exit;
  _log('Create pRenderer');
  GraphBuilder.AddFilter(pRenderer, 'VideoRenderer');
  if failed(pRenderer.QueryInterface(IID_IVMRFilterConfig,
            pConfig)) then exit;
  _log('Add Filter IVMRFilter');
  pConfig.SetNumberOfStreams(1);
  if failed(pRenderer.QueryInterface(IID_IVMRMixerBitmap,
            pBitmap)) then exit;
  _log('Create IVMRMixerBitmap');
А вообще kutani прав проще взять уже полностью рабочий код. Если для вас он сложный можете выкинуть лишнее.
Хорошо поставленный вопрос это уже половина ответа. | Каков вопрос, таков ответ.
У дзен программиста программа делает то что он хотел, а не то что он написал .
Pavia вне форума Ответить с цитированием
Старый 30.10.2016, 23:42   #13
alman12
Форумчанин
 
Регистрация: 30.12.2013
Сообщений: 466
По умолчанию

сделал как сказали, но тогда вообще не появилось видео толка пустой панел
alman12 вне форума Ответить с цитированием
Старый 31.10.2016, 22:25   #14
kutani
Форумчанин
 
Регистрация: 23.01.2016
Сообщений: 608
По умолчанию

)))

Цитата:
какая разница чей код в интернете везде есть этот код
разница в бездумном копипасте с него. Вы бы DirectShow по-русски почитали для разнообразия что-ли, раз публикации первоисточника для вас не аргумент.
kutani вне форума Ответить с цитированием
Старый 01.11.2016, 00:24   #15
alman12
Форумчанин
 
Регистрация: 30.12.2013
Сообщений: 466
По умолчанию

копипасте не бездумный
alman12 вне форума Ответить с цитированием
Старый 01.11.2016, 06:27   #16
Pavia
Лис
Старожил
 
Аватар для Pavia
 
Регистрация: 18.09.2015
Сообщений: 2,409
По умолчанию

alman12
Покажите весь код.
Хорошо поставленный вопрос это уже половина ответа. | Каков вопрос, таков ответ.
У дзен программиста программа делает то что он хотел, а не то что он написал .
Pavia вне форума Ответить с цитированием
Старый 01.11.2016, 12:30   #17
alman12
Форумчанин
 
Регистрация: 30.12.2013
Сообщений: 466
По умолчанию

Код:
unit Unit1;

interface

uses
...directshow9, ActiveX;

type
  TForm1 = class(TForm)
    Button1: TButton;
    ListBox1: TListBox;
    ListBox2: TListBox;
    Panel1: TPanel;
    Panel2: TPanel;
    SaveDialog1: TSaveDialog;
    Button2: TButton;
    Timer1: TTimer;
  function Initializ: HResult;
 function CreateGraph: HResult;
    procedure FormCreate(Sender: TObject);
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure Timer1Timer(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;
  FileName:string; 
  RecMode: Boolean = False;
  DeviceName:OleVariant;
  PropertyName:IPropertyBag;
  pDevEnum:ICreateDEvEnum; 
  pEnum:IEnumMoniker;
  pMoniker:IMoniker;
  MArray1,MArray2: array of IMoniker;
pConfig      : IVMRFilterConfig;
  pBitmap      : IVMRMixerBitmap;
  VMRBitmap    : VMRALPHABITMAP;
  b: tbitmap;
  osb: tbitmap;
  w,h: integer;
    FGraphBuilder:        IGraphBuilder;
    FCaptureGraphBuilder: ICaptureGraphBuilder2;
    FMux:                 IBaseFilter;
    FSink:                IFileSinkFilter;
    FMediaControl:        IMediaControl;
    FVideoWindow:         IVideoWindow;
    FVideoCaptureFilter:  IBaseFilter;
    FAudioCaptureFilter:  IBaseFilter;
    FVideoRect:           TRect;

implementation

{$R *.dfm}

procedure dsmp_logo(s: string; alpha: single);
begin
if Assigned(FVideoWindow)then begin
  osb.Width := length(s)*w;
  osb.Height:= h;
  osb.Canvas.TextOut(0,0,s);
  ZeroMemory(@VMRBitmap, sizeof(VMRBitmap));
  VMRBitmap.dwFlags  := VMRBITMAP_HDC or VMRBITMAP_SRCCOLORKEY;
  VMRBitmap.clrSrcKey:= clBLACK;
  VMRBitmap.hdc      := osb.Canvas.Handle;
  VMRBitmap.rSrc     := osb.Canvas.ClipRect;
  VMRBitmap.rDest.left  := 0.20;
  VMRBitmap.rDest.right := 1.50;
  VMRBitmap.rDest.top   := 0.85;
  VMRBitmap.rDest.bottom:= 0.9;
  VMRBitmap.fAlpha      := alpha;
  pBitmap.SetAlphaBitmap(VMRBitmap);
 end ;
end;


procedure TForm1.FormCreate(Sender: TObject);
begin
 osb:= tbitmap.Create;
  osb.Canvas.Brush.Color:= $0;
  osb.Canvas.Font.Name:= 'System';
  osb.Canvas.Font.Size:= 70;
  osb.Canvas.Font.Style:= [fsBold];
  osb.Canvas.Font.Color:= 65100;// 65280
  w:= osb.Canvas.TextWidth('w');
  h:= osb.Canvas.TextHeight('w');
CoInitialize(nil);
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('Камера не обнаружена');
            End;
end;

function TForm1.Initializ: HResult;
begin
Result:=CoCreateInstance(CLSID_SystemDeviceEnum, NIL, CLSCTX_INPROC_SERVER,
IID_ICreateDevEnum, pDevEnum);
if Result<>S_OK then EXIT;
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); 
if FAILED(Result) then Continue;
Result:=PropertyName.Read('FriendlyName', DeviceName, NIL); 
if FAILED(Result) then Continue;
Listbox1.Items.Add(DeviceName);
end;
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); 
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;

 procedure TForm1.Timer1Timer(Sender: TObject);
begin
 dsmp_logo('syenta )))' +
           ' [ '+
           formatdatetime('hh:nn:ss.zzz',time)+
           ' ]',
           0.5);
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
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 TForm1.Button2Click(Sender: TObject);
begin

end;

function TForm1.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;

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);
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;
end.

Последний раз редактировалось alman12; 01.11.2016 в 13:42.
alman12 вне форума Ответить с цитированием
Старый 01.11.2016, 12:34   #18
Alex11223
Старожил
 
Аватар для Alex11223
 
Регистрация: 12.01.2011
Сообщений: 19,500
По умолчанию

Про эту кнопку так и не понял?

Ушел с форума, https://www.programmersforum.rocks, alex.pantec@gmail.com, https://github.com/AlexP11223
ЛС отключены Аларом.
Alex11223 вне форума Ответить с цитированием
Старый 01.11.2016, 12:55   #19
alman12
Форумчанин
 
Регистрация: 30.12.2013
Сообщений: 466
По умолчанию

знаю, забыл эту кнопку
alman12 вне форума Ответить с цитированием
Старый 01.11.2016, 13:29   #20
Alex11223
Старожил
 
Аватар для Alex11223
 
Регистрация: 12.01.2011
Сообщений: 19,500
По умолчанию

А еще есть такая кнопка

Ушел с форума, https://www.programmersforum.rocks, alex.pantec@gmail.com, https://github.com/AlexP11223
ЛС отключены Аларом.
Alex11223 вне форума Ответить с цитированием
Ответ


Купить рекламу на форуме - 42 тыс руб за месяц

Опции темы Поиск в этой теме
Поиск в этой теме:

Расширенный поиск


Похожие темы
Тема Автор Раздел Ответов Последнее сообщение
Наложения текстур (OpenGl C++) MHZ-MHZ Общие вопросы C/C++ 0 08.02.2016 23:06
как кинуть потоковое видео с вебкамер deniscatch Свободное общение 4 07.12.2013 12:55
Пробелма наложения background NidHelp HTML и CSS 8 24.09.2011 21:25
Наложения объектов в C++ fmx999 Общие вопросы C/C++ 3 01.04.2010 17:39
''Слои'' наложения изображений. Alex Cones Мультимедиа в Delphi 3 11.04.2009 17:03