モバイルの場合には TCameraComponent.Kind プロパティで前面/背面カメラを切り替えられるのですが、Windows の場合には USB 外付けカメラが使える事もあって Kind プロパティでの変更はできない事が多いです。以下のユニットを使えばカメラを任意で切り替える事ができます。
[FMX.CameraComponentEx]
unit FMX.CameraComponentEx;
interface
uses System.Classes, FMX.Media;
type { TCameraComponentHelper } TCameraComponentHelper = class helper for TCameraComponent private procedure SetCameraDevice(const Value: TCaptureDevice); function GetCameraDevice: TCaptureDevice; public property CameraDevice: TCaptureDevice read GetCameraDevice write SetCameraDevice; end;
{ TCameraList } TCameraList = class private FCamList: TStringList; FCount: Integer; function GetItems(Index: Integer): TCaptureDevice; public constructor Create; destructor Destroy; override; property Count: Integer read FCount; property Items[Index: Integer]: TCaptureDevice read GetItems; end;
implementation
{ TCameraComponentHelper }
function TCameraComponentHelper.GetCameraDevice: TCaptureDevice; begin result := Self.FDevice; end;
procedure TCameraComponentHelper.SetCameraDevice(const Value: TCaptureDevice); begin Self.FDevice := TVideoCaptureDevice(Value); end;
{ TCameraList }
constructor TCameraList.Create; var CaptureDeviceList: TCaptureDeviceList; i: Integer; begin {$IFDEF MACOS} DefaultSystemCodePage := 65001; {$ENDIF} FCamList := TStringList.Create; CaptureDeviceList := TCaptureDeviceManager.Current.GetDevicesByMediaType(TMediaType.Video); for i:=0 to CaptureDeviceList.Count-1 do FCamList.Add(CaptureDeviceList[i].Name); FCount := CaptureDeviceList.Count; end;
destructor TCameraList.Destroy; begin FCamList.Free; inherited; end;
function TCameraList.GetItems(Index: Integer): TCaptureDevice; begin if (Index < 0) or (Index >= FCount) then begin result := nil; Exit; end; result := TCaptureDeviceManager.Current.GetDevicesByName(FCamList[Index]); end;
end.
使い方はこんな感じです。フォームには
- Button1 (TButton)
- Button2 (TButton)
- Image1 (TImage)
- CameraComponent1 (TCameraComponent)
が貼ってあります。
unit Unit1;
interface
uses System.SysUtils, System.Types, System.UITypes, System.Rtti, System.Classes, System.Variants, FMX.Types, FMX.Controls, FMX.Forms, FMX.Dialogs, FMX.StdCtrls, FMX.Media, FMX.Objects, FMX.ListBox, FMX.CameraComponentEx;
type TForm1 = class(TForm) Image1: TImage; Button1: TButton; Button2: TButton; CameraComponent1: TCameraComponent; procedure FormCreate(Sender: TObject); procedure FormDestroy(Sender: TObject); procedure Button1Click(Sender: TObject); procedure Button2Click(Sender: TObject); procedure VideoCamera_SampleBufferSync; procedure CameraComponent1SampleBufferReady(Sender: TObject; const ATime: Int64); private { private 宣言 } FCurrentIndex: Integer; CameraList: TCameraList; public { public 宣言 } end;
var Form1: TForm1;
implementation
{$R *.fmx}
procedure TForm1.FormCreate(Sender: TObject); // フォーム作成時 begin FCurrentIndex := -1; CameraList := TCameraList.Create; // カメラがあればインデックスを 0 に if CameraList.Count > 0 then FCurrentIndex := 0; end;
procedure TForm1.FormDestroy(Sender: TObject); // フォーム破棄時 begin if CameraComponent1.Active then CameraComponent1.Active := False; CameraList.Free; end;
procedure TForm1.Button1Click(Sender: TObject); // ボタン 1 押下処理 begin // カメラの有効 / 無効の切り替え if CameraList.Count = 0 then Exit; CameraComponent1.Active := not CameraComponent1.Active; end;
procedure TForm1.Button2Click(Sender: TObject); // ボタン 2 押下処理 var IsActive: Boolean; begin if CameraList.Count = 0 then Exit; // カメラの切り替え (トグル) IsActive := CameraComponent1.Active; CameraComponent1.Active := False; Inc(FCurrentIndex); FCurrentIndex := FCurrentIndex mod CameraList.Count; CameraComponent1.CameraDevice := CameraList.Items[FCurrentIndex]; if IsActive then CameraComponent1.Active := True; end;
procedure TForm1.CameraComponent1SampleBufferReady(Sender: TObject; const ATime: Int64); // カメラ画像の取得 begin TThread.Synchronize(TThread.CurrentThread, VideoCamera_SampleBufferSync); end;
procedure TForm1.VideoCamera_SampleBufferSync; // カメラ画像の取得 begin CameraComponent1.SampleBufferToBitmap(Image1.Bitmap, True); end; end.
理屈上は OS X でも動作するハズですが、動作確認できる環境を持っていないので Windows 用としておきます。
See Also:
[TCameraComponent (FireMonkey Tips)]
http://ht-deko.minim.ne.jp/techf001_additional.html#TCameraComponent
|