DELETED MESSAGE

[M.A.D.M.A.N.]

Надо глянуть, что вообще умеет делать AVICAP32.DLL, может у нее есть альтернативные методы вывода.

Можно попытаться выцепить с того окна обработчик сообщений.

[Bargest]

Есть вроде в авикапе возможность ставить колбэк-функцию. Ей передается тупо массив байт, по всей видимости прямо так, как приходит с камеры. С одной моей камеры, например, приходил в YUV2, а с другой - в MJPEG кадре.

[icsander]

Сам не пробовал, но... по отзывам (пробовал использовать поверхностно), эта библиотека довольно глючна. Как вариант - пользовать DSPack. Есть еще много подобных библиотек (гугл в помощь).

[Bob256]

Что то типа ip камеры. Давно дело было. Забросил...

DELETED MESSAGE

[AlexSku]

Пример на DirectShow (можно изображение делать зеркальным)
файл проекта:

Код:

program Grabber;

uses
  ActiveX,
  Forms,
  Unit1 in 'Unit1.pas' {Form1},
  ConFilters in 'ConFilters.pas';

{$R *.res}

begin
  Application.Initialize;
  // Initialize the COM system
  CoInitialize(nil);

  Application.CreateForm(TForm1, Form1);
  Application.Run;

  // Shut down the COM system
  CoUninitialize();
end.

[AlexSku]

Код:

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;

[AlexSku]

продолжение

Код:

procedure TForm1.btnPauseClick(Sender: TObject);
var
  hr: HResult;
  cbBuffer: Integer;
  evCode: Integer;
  pBuffer: Pointer; // PByteArray
  pVih: PVIDEOINFOHEADER;
  mt: TAMMediaType;
begin
  pControl.Pause();
  btnRun.Enabled:= true;
  btnPause.Enabled:= false;

  { ISampleGrabber.GetCurrentBuffer копирует данные (вызываем 2 раза, первый
  раз, чтобы узнать размер кадра) в наш буфер }
  // Find the required buffer size.
  cbBuffer:= 0;
  hr:= pGrabber.GetCurrentBuffer(cbBuffer, nil);

  GetMem(pBuffer, cbBuffer);
  if not Assigned(pBuffer) then
  begin
    // Out of memory. Return an error code.
    Exit;
  end;
  hr:= pGrabber.GetCurrentBuffer(cbBuffer, pBuffer);

  // The ISampleGrabber::GetConnectedMediaType method returns the format of the buffer:
  hr:= pGrabber.GetConnectedMediaType(mt);
  if FAILED(hr) then
  begin
    // Return error code.
    Exit;
  end;

  // Examine the format block.
  if IsEqualGUID(mt.formattype, FORMAT_VideoInfo)
    and (mt.cbFormat >= sizeof(VIDEOINFOHEADER))
    and Assigned(mt.pbFormat) then
    pVih:= mt.pbFormat
  else
  begin
    // Wrong format. Free the format block and return an error.
    FreeMediaType(@mt);
    Exit; //return VFW_E_INVALIDMEDIATYPE;
  end;

  // You can use the media type to access the BITMAPINFOHEADRE information.
  // For example, the following code draws the bitmap using GDI:
  SetDIBitsToDevice(
    GetDC(PanelVideo.Handle), 0, 0,
    pVih.bmiHeader.biWidth,
    pVih.bmiHeader.biHeight,
    0, 0,
    0,
    pVih.bmiHeader.biHeight,
    pBuffer,
    PBITMAPINFO(@pVih.bmiHeader)^,
    DIB_RGB_COLORS
  );
  // Free the format block when you are done:
  FreeMediaType(@mt);

  FreeMem(pBuffer, cbBuffer);
end;

procedure TForm1.btnRunClick(Sender: TObject);
begin
  pControl.Run;
  btnPause.Enabled:= true;
  btnRun.Enabled:= false;
end;

end.

форма:

Код:

object Form1: TForm1
  Left = 277
  Top = 160
  Width = 768
  Height = 576
  Caption = 'Видеозахват'
  Color = clBtnFace
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clWindowText
  Font.Height = -11
  Font.Name = 'MS Sans Serif'
  Font.Style = []
  Menu = MainMenu1
  OldCreateOrder = False
  Position = poDefaultPosOnly
  ScreenSnap = True
  OnClose = FormClose
  OnCreate = FormCreate
  PixelsPerInch = 96
  TextHeight = 13
  object btnExit: TButton
    Left = 8
    Top = 472
    Width = 75
    Height = 25
    Cancel = True
    Caption = 'Exit'
    TabOrder = 0
    OnClick = btnExitClick
  end
  object StatusBar1: TStatusBar
    Left = 0
    Top = 511
    Width = 760
    Height = 19
    Panels = <>
  end
  object PanelVideo: TPanel
    Left = 100
    Top = 16
    Width = 640
    Height = 480
    TabOrder = 2
    object Label1: TLabel
      Left = 36
      Top = 36
      Width = 32
      Height = 13
      Caption = 'Label1'
    end
  end
  object chbMirror: TCheckBox
    Left = 8
    Top = 16
    Width = 69
    Height = 17
    Caption = 'Зеркало'
    Checked = True
    State = cbChecked
    TabOrder = 3
    OnClick = chbMirrorClick
  end
  object btnPause: TButton
    Left = 8
    Top = 148
    Width = 75
    Height = 25
    Caption = 'Pause'
    Enabled = False
    TabOrder = 4
    OnClick = btnPauseClick
  end
  object btnRun: TButton
    Left = 8
    Top = 188
    Width = 75
    Height = 25
    Caption = 'Run'
    Enabled = False
    TabOrder = 5
    OnClick = btnRunClick
  end
  object MainMenu1: TMainMenu
    Left = 28
    Top = 64
    object Devices: TMenuItem
      Caption = 'Видеовход'
    end
  end
end

[AlexSku]

Код:

unit ConFilters;

interface

uses DirectShow9;

function GetUnconnectedPin(
  pFilter: IBaseFilter;    // Pointer to the filter.
  PinDir: PIN_DIRECTION;   // Direction of the pin to find.
  out ppPin: IPin              // Receives a pointer to the pin.
  ): HRESULT;

function ConnectFilters(
  pGraph: IGraphBuilder; // Filter Graph Manager.
  pOut: IPin;            // Output pin on the upstream filter.
  pDest: IBaseFilter     // Downstream filter.
  ): HRESULT; overload;

function ConnectFilters(
  pGraph: IGraphBuilder;
  pSrc, pDest: IBaseFilter): HRESULT; overload;

implementation

uses Windows, ActiveX;

function GetUnconnectedPin(
  pFilter: IBaseFilter;
  PinDir: PIN_DIRECTION;
  out ppPin: IPin
  ): HRESULT;
var
  pEnum: IEnumPins;
  pPin:  IPin;
  ThisPinDir: TPinDirection;
  pTmp: IPin;
begin
  Result:= pFilter.EnumPins(pEnum);
  if FAILED(Result) then Exit;

  while pEnum.Next(1, pPin, nil) = S_OK do
  begin
    pPin.QueryDirection(ThisPinDir);
    if ThisPinDir = PinDir then
    begin
      Result:= pPin.ConnectedTo(pTmp);
      if SUCCEEDED(Result) then  // Already connected, not the pin we want.
        pTmp:= nil
      else  // Unconnected, this is the pin we want.
      begin
        pEnum:= nil;
        ppPin:= pPin;
        Result:= S_OK;     Exit;
      end;
    end;
    pPin:= nil;
  end;
  pEnum:= nil;
  // Did not find a matching pin.
  Result:= E_FAIL;
end;

function ConnectFilters(
  pGraph: IGraphBuilder; // Filter Graph Manager.
  pOut: IPin;            // Output pin on the upstream filter.
  pDest: IBaseFilter     // Downstream filter.
  ): HRESULT;
var
  pIn: IPin;
begin
  // Find an input pin on the downstream filter.
  Result:= GetUnconnectedPin(pDest, PINDIR_INPUT, pIn);
  if FAILED(Result) then Exit;

  // Try to connect them.
  Result:= pGraph.Connect(pOut, pIn);
  pIn:= nil;
end;

function ConnectFilters(
  pGraph: IGraphBuilder;
  pSrc, pDest: IBaseFilter): HRESULT;
var
  pOut: IPin;
begin
  // Find an output pin on the first filter.
  Result:= GetUnconnectedPin(pSrc, PINDIR_OUTPUT, pOut);
  if FAILED(Result) then Exit;

  Result:= ConnectFilters(pGraph, pOut, pDest);
  pOut:= nil;
end;

end.

[Aristarh Dark]

AlexSku, это троллинг такой? Проект вложить не судьба?

[angvelem]

С кодом не разбирался, но то ли косяк, то ли фича такая - кнопка "Pause" меняет изображение (уменьшает).
И ещё, очень высокая контрастность.

[Aristarh Dark]

angvelem, ты спишь когда-нить?

[angvelem]

[offtop]
Угу, днём.
[/offtop]

[AlexSku]

Сообщение от Aristarh Dark

AlexSku, это троллинг такой? Проект вложить не судьба?

Пардон.
Что такое троллинг?
Я могу вкладывать проект, но сам когда вижу код, то просто его читаю и делаю ^C, ^V, а если вижу вложение, то как правило ленюсь туда лезть (точнее, идёшь на какой-нибудь сайт за информацией, а тебе рекламу с порнушкой кидают).