Einzelnen Beitrag anzeigen

QuickAndDirty

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

AW: FMX TCameracomponent geht auf Windows nicht ?

  Alt 27. Apr 2023, 10: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
Monads? Wtf are Monads?

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