How to get a snapshot from a webcam with Delphi7 using VFrames(TVideoImage)

Question

I\'m using Delphi7 and VFrames (TVideoImage) with this Procedure

uses  VFrames;
....
procedure TForm1.snapshot;
var
cam:TVideoImage;
strlst:TStringList;
BM         


        

Answer 1

I made a small wrapper class for VFrames/VSample:

unit u_class_webcam;

interface

uses
  Jpeg,
  Forms,
  VSample,
  VFrames,
  Classes,
  Graphics,
  SysUtils;


type
  TWebcam = class
  private
    Video       : TVideoImage;
    Devices     : TStringList;
    Resolutions : TStringList;
    function GetDeviceReady: Boolean;
    function GetHeight: Integer;
    function GetWidth: Integer;
    function GetActiveDevice: String;
  public
    constructor Create;
    destructor Destroy; override;
    procedure SetDisplayCanvas(const Canvas : TCanvas);
    procedure TakeSnapshot(const Filename : String);
    function TakeSnapshotToBmp : TBitmap;
    procedure Start;
    procedure Stop;
    property DeviceReady : Boolean read GetDeviceReady;
    property Width : Integer read GetWidth;
    property Height : Integer read GetHeight;
    property ActiveDevice : String read GetActiveDevice;
  end;

// webcam singleton
var
  Webcam : TWebcam;

implementation

{ TWebcam }
function TWebcam.GetActiveDevice: String;
begin
 Result := '';
 if Devices.Count > 0 then
  Result := Devices[0];
end;

function TWebcam.GetHeight: Integer;
begin
 Result := Video.VideoHeight;
end;

function TWebcam.GetWidth: Integer;
begin
 Result := Video.VideoWidth;
end;

function TWebcam.GetDeviceReady: Boolean;
begin
 Video.GetListOfDevices(Devices);
 Result := Devices.Count > 0;
end;

procedure TWebcam.SetDisplayCanvas(const Canvas : TCanvas);
begin
 Video.SetDisplayCanvas(Canvas);
end;

function TWebcam.TakeSnapshotToBmp : TBitmap;
begin
 Result := TBitmap.Create;
 Bitmap.PixelFormat := pf24bit;
 Video.GetBitmap(Result);
end;

procedure TWebcam.TakeSnapshot(const Filename: String);

var
  Bitmap : TBitmap;
  Jpeg   : TJpegImage;

begin
 Bitmap := TBitmap.Create;
 JPeg := TJpegImage.Create;
 try
  Bitmap.PixelFormat := pf24bit;
  Video.GetBitmap(Bitmap);
  JPeg.Assign(Bitmap);
  JPeg.SaveToFile(Filename);
 finally
  Bitmap.Free;
  JPeg.Free;
 end;
end;

procedure TWebcam.Start;
begin
 if DeviceReady then
  begin
   Video.VideoStart(Devices[0]);
   Video.GetListOfSupportedVideoSizes(Resolutions);
   Video.SetResolutionByIndex(Resolutions.Count-1);
  end;
end;

procedure TWebcam.Stop;
begin
 if Video.VideoRunning then
  Video.VideoStop;
end;

constructor TWebcam.Create;
begin
 Devices := TStringList.Create;
 Resolutions := TStringList.Create;
 Video := TVideoImage.Create;
end;

destructor TWebcam.Destroy;
begin
 Stop;
 Devices.Free;
 Resolutions.Free;
 Application.ProcessMessages;
 Video.Free;
end;

end.

usage:

procedure TForm1.TestIt;

var Bmp : TBitmap;

begin
 WebCam := TWebCam.Create;
 try
  WebCam.Start;
  WebCam.SetDisplayCanvas(Self.Canvas); 
  Bmp := WebCam.TakeSnapShotToBmp;
  // do something with BMP
  Bmp.Free;
  WebCam.Stop;
 finally
  WebCam.Free;
 end;
end;

Answer 2

Since the GetBitmap Function of TVideoImage may deliver empty images if directly called after the call to VideoStart, it might be necessary to Create TVideoImage add an OnNewVideoFrame event to get the information that an image is available. So the steps would be:

1. Create and start
2. wait for an image an take it
3. Free

Since the question was asking for a single shot solution and threading or idle looping after VideoStart do not work, I'd provide a solutions which would encapsulate the mentioned steps.

The call would be:

procedure TMyForm.FormCreate(Sender: TObject);
begin
  ReportMemoryLeaksOnShutDown := true;
end;

procedure TMyForm.ImgCallBack(BMP:TBitMap);
begin
    Image1.Picture.Assign(BMP);
end;

procedure TMyForm.Button3Click(Sender: TObject);
begin
    With TGrabClass.Create do GetImage(ImgCallBack);
end;

with the base implementation of TGrabClass of:

unit u_GrabOnlyBitMap;

interface
uses
  Classes,
  Messages,
  Windows,
  Graphics,
  VSample,
  VFrames;
  type

  TImageCallBack=Procedure(bmp:TBitMap) of Object;

  TGrabClass=Class
     FReady:Boolean;
     FVideo:TVideoImage;
     FBitMap:TBitMap;
     Handle:THandle;
     FImageCallBack:TImageCallBack;
     Procedure GetImage(cb:TImageCallBack);
     Constructor Create;
     Destructor Destroy;Override;
  private
    procedure NewVideoFrameEvent(Sender: TObject; Width, Height: integer;
      DataPtr: pointer);
    procedure WndMethod(var Msg: TMessage);
    procedure Suicide;
  End;
implementation

const
WM_MyKill=WM_user + 666;


// Called by asnc PostMessage with WM_MyKill to free
Procedure TGrabClass.WndMethod(var Msg: TMessage);
begin
   if Msg.Msg = WM_MyKill  then
   begin
     Msg.Result := -1;
     Free;
   end
   else
    Msg.Result := DefWindowProc(Handle, Msg.Msg, Msg.wParam, Msg.lParam);
end;


constructor TGrabClass.Create;
var
 sl:TStringList;
begin
  inherited;
  Handle :=  AllocateHWnd(WndMethod);
  sl:=TStringList.Create;
  FVideo:=TVideoImage.Create;
  FBitMap := TBitmap.Create;
  FVideo.OnNewVideoFrame := NewVideoFrameEvent;
  FVideo.GetListOfDevices(sl);
  FReady := sl.Count > 0;
  if FReady then FVideo.VideoStart(sl[0])
  else Suicide;
  sl.Free;
end;

destructor TGrabClass.Destroy;
begin
  DeallocateHWnd(Handle);
  FVideo.VideoStop;
  FVideo.Free;
  FBitMap.Free;
  inherited;
end;

Procedure TGrabClass.Suicide;
begin
  // No device found Callback with empty image and Postmessage for freeing
  if Assigned(FImageCallBack) then FImageCallBack(FBitMap);
  PostMessage(handle,WM_MyKill,0,0);
end;

Procedure TGrabClass.NewVideoFrameEvent(Sender : TObject; Width, Height: integer; DataPtr: pointer);
begin  // we got a bitmap
   FVideo.OnNewVideoFrame := Nil;
   FVideo.GetBitmap(FBitMap);
   if Assigned(FImageCallBack) then FImageCallBack(FBitMap);
   PostMessage(handle,WM_MyKill,0,0);
end;


procedure TGrabClass.GetImage(cb: TImageCallBack);
begin
    FImageCallBack := cb;
end;

end.