Problems with TVideoImage [duplicate] - delphi

Question

I'm using Delphi7 and VFrames (TVideoImage) with this Procedure
uses VFrames;
....
procedure TForm1.snapshot;
var
cam:TVideoImage;
strlst:TStringList;
BMP:TBitmap;
begin
strlst := TStringList.Create ;
cam :=TVideoImage.Create;
cam.GetListOfDevices(strlst);
cam.VideoStart(strlst.Strings[0]); //specify a cam by number
//get snapshot
BMP := TBitmap.Create;
cam.GetBitmap(BMP);
BMP.SaveToFile('test.bmp');
cam.VideoStop;
BMP.Free;
end;
Result blank Bitmap file.

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:
Create and start
wait for an image an take it
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.