How capture continuos frames from camera?

Question

I'm using the following code to capture the camera:

unit Webcam;

interface

uses
  Windows, Messages, SysUtils, Graphics, ExtCtrls, Classes, VFW {https://drkb.ru/multimedia/audio/extract_track/ed7dcb6994c641e4};

type
  TCamera = class(TObject)
  private
    class var VideoHwnd: HWND;
    class function FrameCallback(hCapWnd: HWND; lpVHdr: PVIDEOHDR): DWORD;
      stdcall; static;
  public
    constructor Create(Owner: TPanel);
    destructor Destroy; override;
  end;

var
  Camera: TCamera;

implementation

constructor TCamera.Create(Owner: TPanel);
begin
  VideoHwnd := capCreateCaptureWindowA('', WS_CHILD or WS_VISIBLE, 0, 0, 640,
    480, Owner.Handle, 0);
  if (SendMessage(VideoHwnd, WM_CAP_DRIVER_CONNECT, 0, 0) <> 0) then
  begin
    SendMessage(VideoHwnd, WM_CAP_SET_PREVIEW, 1, 0);
    SendMessage(VideoHwnd, WM_CAP_SET_PREVIEWRATE, 1, 0);
    SendMessage(VideoHwnd, WM_CAP_SET_OVERLAY, 1, 0);
    SendMessage(VideoHwnd, WM_CAP_SET_SCALE, 1, 0);
    SendMessage(VideoHwnd, WM_CAP_SET_CALLBACK_FRAME, 1,
      lParam(@FrameCallback));
    SendMessage(VideoHwnd,
      { WM_CAP_GRAB_FRAME } WM_CAP_GRAB_FRAME_NOSTOP, 1, 0);
  end;
end;

destructor TCamera.Destroy;
begin
  if (VideoHwnd <> 0) then
  begin
    SendMessage(VideoHwnd, WM_CAP_DRIVER_DISCONNECT, 1, 0);
    SendMessage(VideoHwnd, WM_CLOSE, 1, 0);
  end;
  inherited;
end;

class function TCamera.FrameCallback(hCapWnd: HWND; lpVHdr: PVIDEOHDR)
  : DWORD; stdcall;
var
  MemoryStream: TMemoryStream;
  BitmapInfo: TBitmapInfo;
  Bitmap: TBitmap;
  Hdb: Thandle;
begin
  FillChar(BitmapInfo, SizeOf(BitmapInfo), 0);

  if (SendMessage(hCapWnd, WM_CAP_GET_VIDEOFORMAT, SizeOf(BitmapInfo),
    lParam(@BitmapInfo)) <> 0) then
  begin
    MemoryStream := TMemoryStream.Create;
    try
      Bitmap := TBitmap.Create;
      try
        with Bitmap do
        begin
          Width := BitmapInfo.bmiHeader.biWidth;
          Height := BitmapInfo.bmiHeader.biHeight;

          case BitmapInfo.bmiHeader.biBitCount of
            1:
              PixelFormat := pf1bit;
            4:
              PixelFormat := pf4bit;
            8:
              PixelFormat := pf8bit;
            15:
              PixelFormat := pf15bit;
            16:
              PixelFormat := pf16bit;
            24:
              PixelFormat := pf24bit;
            32:
              PixelFormat := pf32bit;
          end;

          Hdb := DrawDibOpen;

          DrawDibDraw(Hdb, Canvas.Handle, 0, 0, BitmapInfo.bmiHeader.biWidth,
            BitmapInfo.bmiHeader.biHeight, @BitmapInfo.bmiHeader,
            lpVHdr^.lpdata, 0, 0, BitmapInfo.bmiHeader.biWidth,
            BitmapInfo.bmiHeader.biHeight, 0);

          DrawDibClose(Hdb);

          SaveToStream(MemoryStream);
        end;

        MemoryStream.Position := 0;
      finally
        Bitmap.Free;
      end;
    finally
      MemoryStream.Free;
    end;
  end;
end;

procedure GetDriverList(List: TStrings);
var
  wIndex: Word;
  szDeviceName: array [0 .. MAX_PATH] of AnsiChar;
  szDeviceVersion: array [0 .. MAX_PATH] of AnsiChar;
begin
  List.Clear;
  for wIndex := 0 to 9 do
  begin
    if capGetDriverDescriptionA(wIndex, @szDeviceName, SizeOf(szDeviceName),
      @szDeviceVersion, SizeOf(szDeviceVersion)) then
      List.AddObject(szDeviceName, Pointer(wIndex));
  end;
  if List.Count = 0 then
    RaiseLastOSError;
end;

end.

When my Form is visible, all works fine. On the other hand, when my Form is configured with wsMinimize, or hidden via code for example, only one frame is displayed/captured and then it stops.

Is there a solution for that?

var
  Form2: TForm2;

implementation

{$R *.dfm}

procedure TForm2.FormActivate(Sender: TObject);
begin
  ShowWindow(Handle, SW_HIDE);
end;

end.

EDIT:

I inserted a error callback function suggested in a comment, but all seems well (no error is reported).

 // inside TCamera class (private declarations):

 class function ErrorCallback(hCapWnd: HWND; nErrID: Integer;
   lpErrorText: LPTSTR): LRESULT; stdcall; static;

 //...

class function TCamera.ErrorCallback(hCapWnd: HWND; nErrID: Integer;
  lpErrorText: LPTSTR): LRESULT; stdcall;
begin
  Result := 1;

  if hCapWnd <= 0 then
  begin
    Result := 0;
    Exit;
  end;

  if nErrID = 0 then
  begin
    Result := 1;
    Exit;
  end;

  Writeln(IntToStr(nErrID) + ' : ' + PAnsiChar(lpErrorText) + ' : ' +
    IntToStr(hCapWnd));
end;

If you'd also send [`WM_CAP_SET_CALLBACK_ERROR`](https://learn.microsoft.com/en-us/windows/win32/multimedia/wm-cap-set-callback-error) you might see what the culprit is, but as of now you simply ignore potential errors. — AmigoJack, Jul 14 '22 at 11:31

Remy Lebeau · Accepted Answer · 2022-07-14T21:44:00.660

Per the WM_CAP_GRAB_FRAME_NOSTOP documentation:

The WM_CAP_GRAB_FRAME_NOSTOP message fills the frame buffer with a single uncompressed frame from the capture device and displays it. Unlike with the WM_CAP_GRAB_FRAME message, the state of overlay or preview is not altered by this message. You can send this message explicitly or by using the capGrabFrameNoStop macro.

The WM_CAP_GRAB_FRAME documentation similarly says:

The WM_CAP_GRAB_FRAME message retrieves and displays a single frame from the capture driver. After capture, overlay and preview are disabled. You can send this message explicitly or by using the capGrabFrame macro.

So, you are asking the capture window for 1 frame at a time, so that is what you are getting.

To capture frames continuously, you would have to either:

send WM_CAP_GRAB_FRAME(_NOSTOP) inside the frame callback to request the next frame.
use WM_CAP_SEQUENCE_NOFILE with WM_CAP_SET_CALLBACK_VIDEOSTREAM, rather than using WM_CAP_GRAB_FRAME(_NOSTOP) with WM_CAP_SET_CALLBACK_FRAME.

How capture continuos frames from camera?

1 Answers1

Linked