Einzelnen Beitrag anzeigen

QuickAndDirty

Registriert seit: 13. Jan 2004
Ort: Hamm(Westf)
2.046 Beiträge
 
Delphi 12 Athens
 
#2

AW: FMX TCameracomponent geht auf Windows nicht ?

  Alt 27. Apr 2023, 09:06
OK Habe es leicht modifiziert
Jetzt findet er schonmal DIE Webcam.
Delphi-Quellcode:
unit WebcamMain;

interface

uses
  System.SysUtils, System.Types, System.UITypes, System.Classes, System.Variants,
  FMX.Types, FMX.Controls, FMX.Forms, FMX.Graphics, FMX.Dialogs, FMX.Media, FMX.Objects,
  FMX.Controls.Presentation, FMX.StdCtrls;

type
  TForm1 = class(TForm)
    imgCamera: TImage;
    Button1: TButton;
    procedure Button1Click(Sender: TObject);

  private
    { Private-Deklarationen }
    fVideoCamera: TVideoCaptureDevice;
  public
    { Public-Deklarationen }
    procedure GetCamNameList(CamNames:TStrings);
    function VideoCamera: TVideoCaptureDevice;
    procedure SampleBufferReady(Sender: TObject; const ATime: TMediaTime);
  end;

var
  Form1: TForm1;

implementation

{$R *.fmx}

//Test funktion
procedure TForm1.GetCamNameList(CamNames:TStrings); // Listet genau eine Camera auf!! "USB CAMERA"
var
  I: Integer;
  D: TCaptureDevice;
begin
  CamNames.Clear;
  for I := 0 to TCaptureDeviceManager.Current.Count - 1 do
  begin
    D := TCaptureDeviceManager.Current.Devices[I];
    if (D.MediaType = TMediaType.Video) and (D is TVideoCaptureDevice) then
    begin
      CamNames.addObject(d.Name, d);
    end;
  end;
End;

function TForm1.VideoCamera: TVideoCaptureDevice;
var
  I: Integer;
  D: TCaptureDevice;
begin
  Result := FVideoCamera;
  if (Result = nil) and (TCaptureDeviceManager.Current <> nil) then
  begin
    for I := 0 to TCaptureDeviceManager.Current.Count - 1 do
    begin
      D := TCaptureDeviceManager.Current.Devices[I];
      if (D.MediaType = TMediaType.Video) and
         (D is TVideoCaptureDevice) and
         D.IsDefault then
      begin
        Result := TVideoCaptureDevice(D);
        FVideoCamera := Result; //hab das korrigiert...
        Break;
      end;
    end;
    {if Result = nil then
    Begin
      FVideoCamera := Result;
      Result := TCaptureDeviceManager.Current.DefaultVideoCaptureDevice;
    End;}

  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  if VideoCamera <> nil then
  begin
    VideoCamera.OnSampleBufferReady := SampleBufferReady;
    VideoCamera.StartCapture;
  end
end;

procedure TForm1.SampleBufferReady(Sender: TObject; const ATime: TMediaTime);
begin
  TThread.synchronize(TThread.CurrentThread,
    Procedure
    Begin
      VideoCamera.SampleBufferToBitmap(imgCamera.Bitmap, true);
    End
  );
end;

end.
Jedoch wenn ich StartCapture aufrufe scheitert das Programm in der Unit FMX.Media.Win anfolgender stelle
Delphi-Quellcode:
procedure TWindowsVideoCaptureDevice.DoStartCapture;
var
  HR: HResult;
begin
  // Create GraphBuilder
  HR := CoCreateInstance(CLSID_CaptureGraphBuilder2, nil, CLSCTX_INPROC_SERVER,
    IID_ICaptureGraphBuilder2, FCaptureGraphBuilder);
  if Succeeded(HR) then
  begin
    HR := CoCreateInstance(CLSID_FilterGraph, nil, CLSCTX_INPROC_SERVER, IID_IFilterGraph2, FGraphBuilder);
    if Succeeded(HR) then
    begin
      FCaptureGraphBuilder.SetFiltergraph(FGraphBuilder);
      // Get IMediaControl
      FGraphBuilder.QueryInterface(IID_IMediaControl, FMediaControl);
      if FBaseFilter <> nil then
      begin
        // Set Capture
        HR := FGraphBuilder.AddFilter(FBaseFilter, 'Capture');
        if Succeeded(HR) then
        begin
          // Create VMR
          FVMRRenderer := TVMRRenderer.Create;
          FVMRRenderer.FSampleBufferReady := VMRRendererSampleReady;
          FVMRRenderer.AddToGraph(FGraphBuilder);
          // Start
          HR := FCaptureGraphBuilder.RenderStream(@PIN_CATEGORY_CAPTURE, @MEDIATYPE_Video, FBaseFilter, nil, FVMRRenderer.FBaseFilter);
          if Succeeded(HR) then //<<<<<<<<<<<<<<<<<<<<HIER SUCCEEDED(HR) Ist anscheinenend False....WARUM????
          begin
            if FMediaControl <> nil then
            begin
              FMediaControl.Run;
              Exit; // Success
            end;
          end;
        end;
      end;
    end;
  end;
  FMediaControl := nil;
  FCaptureGraphBuilder := nil;
  FGraphBuilder := nil;
  FreeAndNil(FVMRRenderer);
end;
Weiß jemand rat? Sollte ich mal auf Verdacht(ActiveX war im Stack irgendwo zu lesen) einfach CoInitialize aufrufen?
Andreas
Nobody goes there anymore. It's too crowded!

Geändert von QuickAndDirty (27. Apr 2023 um 10:10 Uhr)
  Mit Zitat antworten Zitat