unit Unit1;
interface
uses DirectShow9,
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, ComCtrls, StdCtrls, ExtCtrls, AppEvnts, Menus, ActiveX;
type
TForm1 = class(TForm)
btnExit: TButton;
StatusBar1: TStatusBar;
PanelVideo: TPanel;
chbMirror: TCheckBox;
MainMenu1: TMainMenu;
Devices: TMenuItem;
Label1: TLabel;
btnPause: TButton;
btnRun: TButton;
procedure FormCreate(Sender: TObject);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
procedure btnExitClick(Sender: TObject);
procedure chbMirrorClick(Sender: TObject);
procedure btnPauseClick(Sender: TObject);
procedure btnRunClick(Sender: TObject);
private
{ Private declarations }
procedure OnSelectDevice(Sender: TObject);
procedure Cleanup;
public
{ Public declarations }
pBuild: ICaptureGraphBuilder2;
pGraph: IGraphBuilder;
pEnumCat: IEnumMoniker;
pVideoCapture: IBaseFilter;
pVmr: IBaseFilter;
pVMC: IVMRMixerControl9;
pWc: IVMRWindowlessControl9;
pControl: IMediaControl;
pEvent: IMediaEvent;
pGrabberF: IBaseFilter;
pGrabber: ISampleGrabber;
// pNullRenderer: IBaseFilter;
function InitCaptureGraphBuilder: HRESULT;
function InitWindowlessVMR: HRESULT;
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
uses DSUtil, // FreeMediaType, IID_IPropertyBag
ConFilters;
procedure TForm1.FormCreate(Sender: TObject);
var
hr: HRESULT;
pSysDevEnum: ICreateDevEnum;
dwFlags: Dword;
i: integer;
pMoniker: IMoniker;
pPropBag: IPropertyBag;
varName: OleVARIANT;
Device: TMenuItem;
begin
Label1.Caption:= 'Видеопанель.'#13#10+
'Выберете устройство видеовхода из меню'#13#10+
'и подождите несколько секунд для инициализации.'#13#10+
'Во время просмотра убирайте и ставьте галочку ''Зеркало''';
if Failed(InitCaptureGraphBuilder) then Exit;
// Create the System Device Enumerator.
hr:= CoCreateInstance(CLSID_SystemDeviceEnum, nil, CLSCTX_INPROC_SERVER,
IID_ICreateDevEnum, pSysDevEnum);
if FAILED(hr) then Exit;
// Obtain a class enumerator for the video capture category.
dwFlags:= CDEF_DEVMON_PNP_DEVICE or CDEF_DEVMON_FILTER; // или 0
hr:= pSysDevEnum.CreateClassEnumerator(CLSID_VideoInputDeviceCategory, pEnumCat, dwFlags);
if hr = S_OK then
begin
// Enumerate the monikers.
i:= 0;
while pEnumCat.Next(1, pMoniker, nil) = S_OK do
begin
hr:= pMoniker.BindToStorage(nil, nil, IID_IPropertyBag, pPropBag);
if SUCCEEDED(hr) then
begin
// To retrieve the filter's friendly name, do the following:
VariantInit(varName);
hr:= pPropBag.Read('FriendlyName', varName, nil);
if SUCCEEDED(hr) then
begin
// Display the name in your UI somehow.
Device:= TMenuItem.Create(Devices);
Device.Caption:= varName;
Device.Tag:= i; Inc(i);
Device.OnClick:= OnSelectDevice;
Devices.Add(Device);
end;
VariantClear(varName);
pPropBag:= nil;
end;
pMoniker:= nil;
end; // while
end; // if
pSysDevEnum:= nil;
end; // FormCreate
function TForm1.InitCaptureGraphBuilder: HRESULT; // FormCreate
begin
// Create the Capture Graph Builder.
Result:= CoCreateInstance(CLSID_CaptureGraphBuilder2, nil,
CLSCTX_INPROC_SERVER, IID_ICaptureGraphBuilder2, pBuild );
if SUCCEEDED(Result) then
begin
// Create the Filter Graph Manager.
Result:= CoCreateInstance(CLSID_FilterGraph, nil, CLSCTX_INPROC_SERVER,
IID_IGraphBuilder, pGraph);
if SUCCEEDED(Result) then
// Initialize the Capture Graph Builder.
pBuild.SetFiltergraph(pGraph)
else
begin
ShowMessage('DirectShow не установлен');
pBuild:= nil;
end;
end;
end;
procedure TForm1.OnSelectDevice(Sender: TObject);
var
pMoniker: IMoniker;
hr: HResult;
rcDest: TRect;
_hdc: HDC;
iBitDepth: Integer;
mt: TAMMediaType;
begin
Label1.Caption:= 'Ждите...'; PanelVideo.Refresh;
pEnumCat.Reset;
pEnumCat.Skip(TMenuItem(Sender).Tag);
pEnumCat.Next(1, pMoniker, nil);
// To create an instance of the filter, do the following:
hr:= pMoniker.BindToObject(nil, nil, IID_IBaseFilter, pVideoCapture);
// Now add the filter to the graph.
if Succeeded(hr) then
hr:= pGraph.AddFilter(pVideoCapture, 'Video Capture Filter');
pMoniker:= nil;
if not Assigned(pVmr) then
if FAILED(InitWindowlessVMR) then Exit;
// Create the Sample Grabber.
hr:= CoCreateInstance(CLSID_SampleGrabber, nil, CLSCTX_INPROC_SERVER,
IID_IBaseFilter, pGrabberF);
if FAILED(hr) then
begin
// Return an error.
Exit;
end;
hr:= pGraph.AddFilter(pGrabberF, 'Sample Grabber');
if FAILED(hr) then
begin
// Return an error.
Exit;
end;
pGrabberF.QueryInterface(IID_ISampleGrabber, pGrabber);
// SetMediaType
ZeroMemory(@mt, sizeof(AM_MEDIA_TYPE));
{ a)
mt.majortype = MEDIATYPE_Video;
mt.subtype = MEDIASUBTYPE_RGB24;
hr = pGrabber->SetMediaType(&mt); }
// б) используется свойства монитора
// Find the current bit depth.
_hdc:= GetDC(0);
iBitDepth:= GetDeviceCaps(_hdc, BITSPIXEL);
ReleaseDC(0, _hdc);
// Set the media type.
mt.majortype:= MEDIATYPE_Video;
case iBitDepth of
8: mt.subtype:= MEDIASUBTYPE_RGB8;
16: mt.subtype:= MEDIASUBTYPE_RGB555;
24: mt.subtype:= MEDIASUBTYPE_RGB24;
32: mt.subtype:= MEDIASUBTYPE_RGB32;
else {Result:= E_FAIL;} Exit;
end;
hr:= pGrabber.SetMediaType(mt);
FreeMediaType(@mt);
// Buidl the filter graph
hr:= ConnectFilters(pGraph, pVideoCapture, pGrabberF);
// a) Buffering mode (копия каждого кадра)
{ активация: ISampleGrabber.SetBufferSamples(true) }
// b) Callback mode (вызов ф-ии на каждом кадре)
{ два способа:
b1) ISampleGrabber.SetCallback(ISampleGrabberCB, 0) -> будет вызываться
SampleCB
b2) ISampleGrabber.SetCallback(ISampleGrabberCB, 1) -> будет вызываться
BufferCB
Если ISampleGrabberCB = nil, то режим Callback заканчивается.
ISampleGrabberCB содержит методы BufferCB (получает указатель на копию
последнего кадра, sample buffer)
и SampleCB (получает указатель на кадр, IMediaSample)
с) ISampleGrabber.SetOneShot(true) получает один кадр и останавливает граф.
Пример. После поиска позиции захватить один кадр:
// Set one-shot mode and buffering.
hr:= pGrabber.SetOneShot(TRUE); }
// Grab the Sample (используем Buffering mode)
hr:= pGrabber.SetBufferSamples(TRUE);
{ hr:= CoCreateInstance(CLSID_NullRenderer, nil, CLSCTX_INPROC_SERVER,
IID_IBaseFilter, pNullRenderer);
hr:= pGraph.AddFilter(pNullRenderer, 'Null Renderer');
hr:= ConnectFilters(pGraph, pGrabberF, pNullRenderer); }
hr:= ConnectFilters(pGraph, pGrabberF, pVmr);
if Succeeded(hr) then
begin
rcDest:= PanelVideo.ClientRect;
// Set the video position.
pWc.SetVideoPosition(nil, @rcDest);
end;
// Run
if Failed(pGraph.QueryInterface(IID_IMediaControl, pControl)) then Exit;
if Failed(pGraph.QueryInterface(IID_IMediaEvent, pEvent)) then Exit;
pControl.Run(); // Run the graph.
btnPause.Enabled:= true;
end;
function TForm1.InitWindowlessVMR: HRESULT;
var
pConfig: IVMRFilterConfig9;
begin
// Create the VMR.
Result:= CoCreateInstance(CLSID_VideoMixingRenderer9, nil, CLSCTX_INPROC,
IID_IBaseFilter, pVmr);
if FAILED(Result) then Exit;
// Add the VMR to the filter graph.
Result:= pGraph.AddFilter(pVmr, 'Video Mixing Renderer');
if FAILED(Result) then
begin
pVmr:= nil;
Exit;
end;
// Set the rendering mode.
Result:= pVmr.QueryInterface(IID_IVMRFilterConfig9, pConfig);
if SUCCEEDED(Result) then
begin
{ Result:=} pConfig.SetRenderingMode(VMR9Mode_Windowless);
Result:= pConfig.SetNumberOfStreams(1);
pConfig:= nil;
end;
if SUCCEEDED(Result) then
begin
Result:= pVmr.QueryInterface(IID_IVMRMixerControl9, pVMC);
if Succeeded(Result) then
chbMirror.OnClick(nil);
// Set the window.
Result:= pVmr.QueryInterface(IID_IVMRWindowlessControl9, pWc);
if SUCCEEDED(Result) then
begin
Result:= pWc.SetVideoClippingWindow(PanelVideo.Handle);
if SUCCEEDED(Result) then
pWc.SetBorderColor($00FF0000)
else
// An error occurred, so release the interface.
pWc:= nil;
end;
end;
end;
procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
Cleanup;
end;
procedure TForm1.btnExitClick(Sender: TObject);
begin
Close;
end;
////////////////////////////////////////////////////////////
procedure TForm1.Cleanup; // FormClose
begin
pControl.Stop;
pControl:= nil;
pEvent:= nil;
pWc:= nil;
pVMC:= nil;
pVmr:= nil;
pVideoCapture:= nil;
pEnumCat:= nil;
pGraph:= nil;
pBuild:= nil;
end; // Cleanup
procedure TForm1.chbMirrorClick(Sender: TObject);
var
vmrRect: TNormalizedRect;
begin
with vmrRect do
begin
top:= 0;
bottom:= 1;
if chbMirror.State = cbChecked then
begin left:= 1; right:=0 end // зеркало
else
begin left:= 0; right:=1 end;
end;
pVMC.SetOutputRect(0, @vmrRect);
end;