Delphi

Question

根据此 Stack Overflow answer 中的提示，我为 Windows 创建了一个简单的应用程序，它可以使用 DirectX 库从网络摄像头获取快照。

现在我正尝试使用 thread 获得相同的结果。这是我到目前为止得到的：

  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;

问题是，在 thread.

中使用时，GetListOfDevices 总是 return 为空

拜托，我做错了什么？谢谢！

编辑：

根据Remy Lebeau 重要提示进行多次测试和调试后，我的结论是在线程内使用TVideoImage 时永远不会触发OnNewVideoFrame。所以我的下一个测试是尝试在创建 TVideoImage 的相同 execute 方法中拍摄网络摄像头，等待几秒钟后，它在第一次工作，但下一次它总是变成空白图像，我需要关闭应用程序并再次打开它才能再次工作。这是我正在使用的代码的摘要：

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;

请问，为什么这段代码在第一次运行时有效，但在下一次运行时总是得到空白的白色图像？谢谢！

Answer 1

DirectX 使用 ActiveX/COM 接口。因此，您的线程的 Execute() 方法需要在访问任何 COM 对象之前通过 CoInitialize/Ex() 为自身初始化 COM 库。

但更重要的是，您正在跨线程边界创建和使用 TVideoImage 对象。大多数 COM 对象并非设计用于跨线程边界使用，因此必须对它们进行封送处理。所以不要那样使用 TVideoImage 。在同一个线程中创建、使用和销毁它（即在您的 Execute() 方法中）。

试试这个：

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;

也就是说，我建议稍微调整一下方法 - 假设 OnNewVideoFrame 事件是异步触发的，线程实际上应该等待事件触发，而不是假设它确实发生了，而且它应该在使用捕获的 JPG 之前停止视频捕获，例如：

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;

更新：您可能需要在您的线程中添加一个消息循环，以便 OnNewVideoFrame 事件正确触发，例如：

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;

Delphi - 使用线程中的 DirectX 捕获网络摄像头快照

Delphi - Capture webcam snapshot using DirectX from a Thread

directx

webcam