时间戳

首页 > 解决方案 > Delphi - 使用 DirectX 从线程捕获网络摄像头快照

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

问题描述

按照这个Stack Overflow 答案中的提示，我为 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;

问题是，GetListOfDevices使用 inside 时总是返回空thread。

请问，我做错了什么？谢谢！

编辑：

经过许多测试和调试后Remy Lebeau，我的结论是在使用内部线程OnNewVideoFrame时永远不会触发。TVideoImage因此，我的下一个测试是尝试在execute创建的相同方法中拍摄网络摄像头TVideoImage，等待几秒钟后，它在第一次工作，但下次它总是得到空白的白色图像，我需要关闭应用程序并打开再次让它工作一次。这是我正在使用的代码的摘要：

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;

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

标签： delphidirectxwebcam

解决方案

DirectX 使用 ActiveX/COM 接口。因此，您的线程的Execute()方法需要CoInitialize/Ex()在访问任何 COM 对象之前为自己初始化 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;

推荐阅读