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

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.