Delphi - Capture webcam snapshot using DirectX from a Thread - delphi

Question

Following the tips from this Stack Overflow answer I created a simple application for Windows that can get a snapshot from the webcam, using DirectX library.
Now I am trying to get the same result using thread. Here is what I got so far:
TGetWebcam = class(TThread)
private
FWCVideo: TVideoImage;
FJpgShot: TJPEGImage;
procedure OnNewVideoFrame(Sender: TObject;
Width, Height: Integer; DataPtr: Pointer);
protected
procedure Execute; override;
public
constructor Create;
destructor Destroy; override;
end;
constructor TGetWebcam.Create;
begin
FreeOnTerminate := True;
FJpgShot := TJPEGImage.Create;
FWCVideo := TVideoImage.Create;
FWCVideo.OnNewVideoFrame := OnNewVideoFrame;
inherited Create(False);
end;
destructor TGetWebcam.Destroy;
begin
FWCVideo.Free;
FJpgShot.Free;
inherited;
end;
procedure TGetWebcam.Execute;
var
TmpLst: TStringList;
JpgImg: TJpegImage;
begin
TmpLst := TStringList.Create;
try
FWCVideo.GetListOfDevices(TmpLst);
if TmpLst.Count <= 0 then Exit;
if FWCVideo.VideoStart(TmpLst[0]) = 0 then
begin
TmpLst.Clear;
FWCVideo.GetListOfSupportedVideoSizes(TmpLst);
if TmpLst.Count <= 0 then Exit;
FWCVideo.SetResolutionByIndex(TmpLst.Count - 1);
JpgImg := TJPEGImage.Create;
try
JpgImg.Assign(FJpgShot);
JpgImg.CompressionQuality := 50;
JpgImg.SaveToFile('c:\test.jpg');
finally
JpgImg.Free;
end;
FWCVideo.VideoStop;
end;
finally
TmpLst.Free;
end;
end;
procedure TGetWebcam.OnNewVideoFrame(Sender: TObject; Width, Height: Integer;
DataPtr: Pointer);
begin
FWCVideo.GetJPG(FJpgShot); // I added this procedure "GetJPG" to VFrames.pas
end;
Problem is, GetListOfDevices always return empty when using inside thread.
Please, what am I doing wrong? Thanks!
EDIT:
After many tests and debugging following Remy Lebeau great tips, my conclusion is that OnNewVideoFrame is never fired when using TVideoImage inside thread. So my next test was trying to get the webcam shot inside the same execute method that creates TVideoImage, after waiting for some seconds, and it worked in the first time, but next time it always get blank white images, I need to close the application and open again for it to work one more time. Here is a abstract of the code I am using:
procedure TGetWebcam.Execute;
var
WCVideo: TVideoImage;
TmpList: TStringList;
JpgShot: TJPEGImage;
begin
CoInitialize(nil);
try
WCVideo := TVideoImage.Create;
try
TmpList := TStringList.Create;
try
WCVideo.GetListOfDevices(TmpList);
if TmpList.Count = 0 then Exit;
if WCVideo.VideoStart(TmpList[0]) <> 0 then Exit;
TmpList.Clear;
WCVideo.GetListOfSupportedVideoSizes(TmpList);
if TmpList.Count = 0 then Exit;
WCVideo.SetResolutionByIndex(ScnResId);
Sleep(5000);
JpgShot := TJPEGImage.Create;
try
WCVideo.GetJPG(JpgShot);
JpgShot.SaveToFile('c:\test.jpg');
finally
JpgShot.Free;
end;
finally
WCVideo.VideoStop;
end;
finally
TmpList.Free;
end;
finally
WCVideo.Free;
end;
finally
CoUninitialize;
end;
end;
Please, why this code works in the first time it runs but in next times always get blank white images? Thanks!

Answer 1

DirectX uses ActiveX/COM interfaces. As such, your thread's Execute() method needs to initialize the COM library for itself via CoInitialize/Ex() before accessing any COM objects.
But more importantly, you are creating and using the TVideoImage object across thread boundaries. Most COM objects are not designed to be used across thread boundaries, they would have to be marshaled in order to do that. So don't use TVideoImage that way. Create, use, and destroy it all within the same thread (ie, inside your Execute() method).
Try this instead:
type
TGetWebcam = class(TThread)
private
FWCVideo: TVideoImage;
FJpgShot: TJPEGImage;
procedure OnNewVideoFrame(Sender: TObject; Width, Height: Integer; DataPtr: Pointer);
protected
procedure Execute; override;
public
constructor Create; reintroduce;
destructor Destroy; override;
end;
...
uses
Winapi.ActiveX;
constructor TGetWebcam.Create;
begin
inherited Create(False);
FreeOnTerminate := True;
FJpgShot := TJPEGImage.Create;
end;
destructor TGetWebcam.Destroy;
begin
FJpgShot.Free;
inherited;
end;
procedure TGetWebcam.Execute;
var
TmpLst: TStringList;
JpgImg: TJpegImage;
begin
CoInitialize(nil);
try
FWCVideo := TVideoImage.Create;
try
FWCVideo.OnNewVideoFrame := OnNewVideoFrame;
TmpLst := TStringList.Create;
try
FWCVideo.GetListOfDevices(TmpLst);
if TmpLst.Count <= 0 then Exit;
if FWCVideo.VideoStart(TmpLst[0]) <> 0 then Exit;
try
TmpLst.Clear;
FWCVideo.GetListOfSupportedVideoSizes(TmpLst);
if TmpLst.Count <= 0 then Exit;
FWCVideo.SetResolutionByIndex(TmpLst.Count - 1);
JpgImg := TJPEGImage.Create;
try
JpgImg.Assign(FJpgShot);
JpgImg.CompressionQuality := 50;
JpgImg.SaveToFile('c:\test.jpg');
finally
JpgImg.Free;
end;
finally
FWCVideo.VideoStop;
end;
finally
TmpLst.Free;
end;
finally
FWCVideo.Free;
end;
finally
CoUninitialize;
end;
end;
procedure TGetWebcam.OnNewVideoFrame(Sender: TObject; Width, Height: Integer; DataPtr: Pointer);
begin
FWCVideo.GetJPG(FJpgShot);
end;
That being said, I would suggest a slightly tweaked approach - assuming the OnNewVideoFrame event is fired asynchronously, the thread should actually wait for the event to fire and not just assume it does, and also it should stop the video capture before using the captured JPG, eg:
uses
..., System.SyncObjs;
type
TGetWebcam = class(TThread)
private
FJpgShot: TJPEGImage;
FJpgShotReady: TEvent;
procedure OnNewVideoFrame(Sender: TObject; Width, Height: Integer; DataPtr: Pointer);
function GetJpgShot: Boolean;
protected
procedure Execute; override;
public
constructor Create; reintroduce;
destructor Destroy; override;
end;
...
uses
Winapi.ActiveX;
constructor TGetWebcam.Create;
begin
inherited Create(False);
FreeOnTerminate := True;
FJpgShot := TJPEGImage.Create;
FJpgShotReady := TEvent.Create;
end;
destructor TGetWebcam.Destroy;
begin
FJpgShot.Free;
FJpgShotReady.Free;
inherited;
end;
procedure TGetWebcam.Execute;
var
JpgImg: TJpegImage;
begin
CoInitialize(nil);
try
if not GetJpgShot() then Exit;
JpgImg := TJPEGImage.Create;
try
JpgImg.Assign(FJpgShot);
JpgImg.CompressionQuality := 50;
JpgImg.SaveToFile('c:\test.jpg');
finally
JpgImg.Free;
end;
finally
CoUninitialize;
end;
end;
function TGetWebcam.GetJpgShot: Boolean;
var
TmpLst: TStringList;
WCVideo: TVideoImage;
begin
Result := False;
WCVideo := TVideoImage.Create;
try
WCVideo.OnNewVideoFrame := OnNewVideoFrame;
TmpLst := TStringList.Create;
try
WCVideo.GetListOfDevices(TmpLst);
if TmpLst.Count < 1 then Exit;
if WCVideo.VideoStart(TmpLst[0]) <> 0 then Exit;
try
TmpLst.Clear;
WCVideo.GetListOfSupportedVideoSizes(TmpLst);
if TmpLst.Count < 1 then Exit;
WCVideo.SetResolutionByIndex(TmpLst.Count - 1);
Result := FJpgShotReady.WaitFor(5000) = wrSignaled;
finally
WCVideo.VideoStop;
end;
finally
TmpLst.Free;
end;
finally
WCVideo.Free;
end;
end;
procedure TGetWebcam.OnNewVideoFrame(Sender: TObject; Width, Height: Integer; DataPtr: Pointer);
begin
TVideoImage(Sender).GetJPG(FJpgShot);
FJpgShotReady.SetEvent;
end;
UPDATE: you might need to add a message loop to your thread in order for the OnNewVideoFrame event to fire correctly, eg:
uses
..., Winapi.Windows;
type
TGetWebcam = class(TThread)
private
FJpgShot: TJPEGImage;
FJpgShotReady: Boolean;
procedure OnNewVideoFrame(Sender: TObject; Width, Height: Integer; DataPtr: Pointer);
function GetJpgShot: Boolean;
protected
procedure Execute; override;
public
constructor Create; reintroduce;
destructor Destroy; override;
end;
...
uses
Winapi.ActiveX;
constructor TGetWebcam.Create;
begin
inherited Create(False);
FreeOnTerminate := True;
FJpgShot := TJPEGImage.Create;
end;
destructor TGetWebcam.Destroy;
begin
FJpgShot.Free;
inherited;
end;
procedure TGetWebcam.Execute;
var
JpgImg: TJpegImage;
begin
CoInitialize(nil);
try
if not GetJpgShot() then Exit;
JpgImg := TJPEGImage.Create;
try
JpgImg.Assign(FJpgShot);
JpgImg.CompressionQuality := 50;
JpgImg.SaveToFile('c:\test.jpg');
finally
JpgImg.Free;
end;
finally
CoUninitialize;
end;
end;
function TGetWebcam.GetJpgShot: Boolean;
var
TmpLst: TStringList;
WCVideo: TVideoImage;
Msg: TMSG;
begin
Result := False;
WCVideo := TVideoImage.Create;
try
WCVideo.OnNewVideoFrame := OnNewVideoFrame;
TmpLst := TStringList.Create;
try
WCVideo.GetListOfDevices(TmpLst);
if TmpLst.Count < 1 then Exit;
if WCVideo.VideoStart(TmpLst[0]) <> 0 then Exit;
try
TmpLst.Clear;
WCVideo.GetListOfSupportedVideoSizes(TmpLst);
if TmpLst.Count < 1 then Exit;
WCVideo.SetResolutionByIndex(TmpLst.Count - 1);
FJpgShotReady := False;
while (not FJpgShotReady) and GetMessage(Msg, 0, 0, 0) do
begin
TranslateMessage(Msg);
DispatchMessage(Msg);
end;
Result := FJpgShotReady;
finally
WCVideo.VideoStop;
end;
finally
TmpLst.Free;
end;
finally
WCVideo.Free;
end;
end;
procedure TGetWebcam.OnNewVideoFrame(Sender: TObject; Width, Height: Integer; DataPtr: Pointer);
begin
TVideoImage(Sender).GetJPG(FJpgShot);
FJpgShotReady := True;
end;