找到你要的答案

Q:TCameraComponent and TVideoCaptureDevice do not initialize in Win32

Q:tcameracomponent和tvideocapturedevice没有初始化在Win32

I use the standard code to initialize TVideoCaptureDevice and start capturing.

const  M_LAUNCH_CAMERA = WM_APP + 450;
type
  TCamSF1 = class(TForm)
...
  protected
    procedure LaunchCamera(var Message: TMessage); message M_LAUNCH_CAMERA;
...
end;
...
procedure TCamSF1.LaunchCamera(var Message: TMessage);
begin
if VideoCamera = nil then
    begin
      VideoCamera := TCaptureDeviceManager.Current.DefaultVideoCaptureDevice;
      if VideoCamera <> nil then
      begin
        VideoCamera.OnSampleBufferReady := CameraReady;
        VideoCamera.StartCapture;
      end
      else
      begin
        Caption := 'Video capture devices not available.';
      end;
    end
    else
    begin
      VideoCamera.StartCapture;
    end;
end;

procedure TCamSF1.IdTCPServer1Execute(AContext: TIdContext);
var
  S: AnsiString;
  Command: TAnsiStrings;
  Msg: TMessage;
begin
  if (AContext <> nil) and (AContext.Connection.Socket.Connected) and
    (not AContext.Connection.Socket.InputBufferIsEmpty) then
    S := AContext.Connection.Socket.ReadLn;
  if S = '' then
    exit;
  Memo1.Lines.Add(S);
  Command := ParseCommandString(S, '#');
  if Command[0] = 'camresol' then
  begin
    CamShotParams := Command;
    Msg.Msg := M_LAUNCH_CAMERA;
    Dispatch(Msg);
  end;
end;

The code properly works when I dispatch a message from a button OnClick event but when the message is dispatched from TIdTCPServer OnExecute the camera does not start and Caption := 'Video capture devices not available.' is run. Moreover, after this the camera does not initialize even from the Button OnClick event.

The code also does not work in case of direct calling of

VideoCamera := TCaptureDeviceManager.Current.DefaultVideoCaptureDevice;
if VideoCamera <> nil then
  begin 
    VideoCamera.OnSampleBufferReady := CameraReady;
    VideoCamera.StartCapture;
  end;

from within Server OnExecute event. Though it works fine when run from the Button OnClick. Using of TCameraComponent cause the same problems. This issue could be reolved if camera initialization is handled in Form OnCreate event but this is not suitable as simultaneous usage of camera is not allowed by two or more applications.

我使用标准的代码来初始化tvideocapturedevice开始捕捉。

const  M_LAUNCH_CAMERA = WM_APP + 450;
type
  TCamSF1 = class(TForm)
...
  protected
    procedure LaunchCamera(var Message: TMessage); message M_LAUNCH_CAMERA;
...
end;
...
procedure TCamSF1.LaunchCamera(var Message: TMessage);
begin
if VideoCamera = nil then
    begin
      VideoCamera := TCaptureDeviceManager.Current.DefaultVideoCaptureDevice;
      if VideoCamera <> nil then
      begin
        VideoCamera.OnSampleBufferReady := CameraReady;
        VideoCamera.StartCapture;
      end
      else
      begin
        Caption := 'Video capture devices not available.';
      end;
    end
    else
    begin
      VideoCamera.StartCapture;
    end;
end;

procedure TCamSF1.IdTCPServer1Execute(AContext: TIdContext);
var
  S: AnsiString;
  Command: TAnsiStrings;
  Msg: TMessage;
begin
  if (AContext <> nil) and (AContext.Connection.Socket.Connected) and
    (not AContext.Connection.Socket.InputBufferIsEmpty) then
    S := AContext.Connection.Socket.ReadLn;
  if S = '' then
    exit;
  Memo1.Lines.Add(S);
  Command := ParseCommandString(S, '#');
  if Command[0] = 'camresol' then
  begin
    CamShotParams := Command;
    Msg.Msg := M_LAUNCH_CAMERA;
    Dispatch(Msg);
  end;
end;

代码正常工作时我派遣一个消息从一个按钮的onclick事件但当消息从tidtcpserver onexecute相机不启动和标题派:= '视频捕获设备不可用。’很。此外,在这个相机不初始化甚至从按钮的onclick事件。

该代码也不工作的情况下,直接调用

VideoCamera := TCaptureDeviceManager.Current.DefaultVideoCaptureDevice;
if VideoCamera <> nil then
  begin 
    VideoCamera.OnSampleBufferReady := CameraReady;
    VideoCamera.StartCapture;
  end;

from within Server OnExecute event. Though it works fine when run from the Button OnClick. Using of TCameraComponent cause the same problems. This issue could be reolved if camera initialization is handled in Form OnCreate event but this is not suitable as simultaneous usage of camera is not allowed by two or more applications.

answer1: 回答1:

It seems, capture device should be initialized and manipulated from the main thread. Try to wrap capture manipulating in TThread.Synchronize class procedure, smth like this:

procedure TMyForm.IdTCPServer1Execute(AContext: TIdContext);
...
begin
...
TThread.Synchronize(nil,
  procedure
  begin
    DoSmthWithCamera();
  end;
);
...
end;

看来,捕获设备应该从主线程初始化和操作。尝试包捕获操纵线。同步类的程序,这样的看法:

procedure TMyForm.IdTCPServer1Execute(AContext: TIdContext);
...
begin
...
TThread.Synchronize(nil,
  procedure
  begin
    DoSmthWithCamera();
  end;
);
...
end;
answer2: 回答2:

The reason why initializing the camera from TIdTCPServer.OnExecute does not work is because the code in the OnExecute event method is by default executed in separate a thread. So you are facing the common problems of accessing VCL in multithreading applications.

You should make sure that your camera initialization and also finalization code is executed from main thread via Synchronization.

The reason why initializing the camera from TIdTCPServer.OnExecute does not work is because the code in the OnExecute event method is by default executed in separate a thread. So you are facing the common problems of accessing VCL in multithreading applications.

你应该确保你的相机的初始化和终止代码执行也从主线程的同步。

answer3: 回答3:

Thank you for your help, my special gratitude to @whosrdaddy, @SilverWarior and @Sergey-Krasilnikov. I have found a way out though it does not seem nice. I decided to use a TTimer. It has the following OnTimer event.

procedure TCamSF1.Timer1Timer(Sender: TObject);
begin
  if IdTCPServer1.Contexts.IsCountLessThan(1) then
  begin
    if (CameraComponent <> nil) and (CameraComponent.Active) then
      CameraComponent.Active := false;
    if CameraComponent <> nil then
    begin
      CameraComponent.Destroy;
      CameraComponent.FreeOnRelease;
      CameraComponent := nil;
    end;
  end
  else
  begin
    if CameraComponent = nil then
    begin
      CameraComponent := TCameraComponent.Create(Self);
      CameraComponent.OnSampleBufferReady := CameraComponentReady;
    end;
    CameraComponent.Active := true;
  end;
end;

So I managed to swich the camera on/off by means of connecting/disconnecting the client. Should you find a better solution, please, kindly let me know.

Thank you for your help, my special gratitude to @whosrdaddy, @SilverWarior and @Sergey-Krasilnikov. I have found a way out though it does not seem nice. I decided to use a TTimer. It has the following OnTimer event.

procedure TCamSF1.Timer1Timer(Sender: TObject);
begin
  if IdTCPServer1.Contexts.IsCountLessThan(1) then
  begin
    if (CameraComponent <> nil) and (CameraComponent.Active) then
      CameraComponent.Active := false;
    if CameraComponent <> nil then
    begin
      CameraComponent.Destroy;
      CameraComponent.FreeOnRelease;
      CameraComponent := nil;
    end;
  end
  else
  begin
    if CameraComponent = nil then
    begin
      CameraComponent := TCameraComponent.Create(Self);
      CameraComponent.OnSampleBufferReady := CameraComponentReady;
    end;
    CameraComponent.Active := true;
  end;
end;

所以我设法开关相机开启/关闭的连接/断开客户端的手段。如果你找到一个更好的解决办法,请,请让我知道。

answer4: 回答4:

The code works properly if to call dispatch in the following way:

procedure TCamSF1.IdTCPServer1Execute(AContext: TIdContext);
var
  Command: TAnsiStrings;
  Msg: TMessage;
begin
  ... 
  if ... then
  begin
    TThread.Synchronize(TThread.CurrentThread, (
      procedure
      begin
        Counter := 0;
        CamShotParams := Command;
        Msg.Msg := M_LAUNCH_CAMERA;
        Dispatch(Msg)
      end));
  end;
end;

如果按下列方式调用调度,代码正常工作:

procedure TCamSF1.IdTCPServer1Execute(AContext: TIdContext);
var
  Command: TAnsiStrings;
  Msg: TMessage;
begin
  ... 
  if ... then
  begin
    TThread.Synchronize(TThread.CurrentThread, (
      procedure
      begin
        Counter := 0;
        CamShotParams := Command;
        Msg.Msg := M_LAUNCH_CAMERA;
        Dispatch(Msg)
      end));
  end;
end;
delphi  firemonkey  indy