Search code examples
delphidirectxwebcam

Delphi - Capture webcam snapshot using DirectX from a Thread

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!

Solution

  • 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;