Webカメラから写真を撮影するアプリを作成～Delphiソースコード集

DelphiにDSPackをインストールしていることが前提

DSPackのインストールはhttps://mam-mam.net/delphi/dspack_install.html を参照してください。

新規アプリケーションの準備

Delphiを起動し
「ファイル」→「新規作成「→「VCLフォームアプリケーション - Delphi」を選択します。
以下のようにフォームに配置します。

TVideoWindow（名前はデフォルトのままのVideoWindow1）をドラッグ＆ドロップでフォーム上に配置しプロパティをWidth=320、height=240にします。
TFilterGraph（名前はデフォルトのままのFilterGraph1）、TFilter（名前はデフォルトのままのFilter1）、 TSampleGrabber（名前はデフォルトのままのSampleGrabber1）をドラッグ＆ドロップします。
TSaveDialog（名前はデフォルトのままのSaviDialog1、DefaultExtプロパティをbmpに、Filterプロパティを *.bmp|*.bmp にします）、TButton（名前はデフォルトのままのButton1、Captionを「撮影」にするとよいでしょう）をドラッグ＆ドロップで配置します。

OnCreateとOnDestroyのプログラムを記述する

フォーム自体をクリックし、イベントOnCreateの右側の空白部分をダブルクリックして以下ソースを記述します。

procedure TForm1.FormCreate(Sender: TObject);
var ICapB:ICaptureGraphBuilder2;
    VideoDevices:TSysDevEnum;       //取り込みビデオデバイスの列挙
begin
  VideoDevices:=TSysDevEnum.Create(CLSID_VideoInputDeviceCategory);
  Filter1.FilterGraph:=FilterGraph1;
  Filter1.BaseFilter.Moniker:=VideoDevices.GetMoniker(0);
  VideoWindow1.FilterGraph:=FilterGraph1;
  SampleGrabber1.FilterGraph:=FilterGraph1;
  FilterGraph1.ClearGraph;
  FilterGraph1.Mode:=gmCapture;
  FilterGraph1.Active:=True;

  ICapB:=FilterGraph1 as ICaptureGraphBuilder2;
  ICapB.RenderStream(@PIN_CATEGORY_PREVIEW,nil,Filter1 as IBaseFilter,
    SampleGrabber1 as IBaseFilter,VideoWindow1 as IBaseFilter);
  FilterGraph1.Play;
  VideoDevices.Free;
end;

同じくフォームを選択してイベントOnDestroyの右側部分をダブルクリックして以下ソースを記述します。

procedure TForm1.FormDestroy(Sender: TObject);
begin
  FilterGraph1.Stop;
  FilterGraph1.Active:=False;
  FilterGraph1.ClearGraph;
end;

撮影（button1）ボタンをダブルクリックしてOnClickイベントを記述する

以下赤字部分を追加しましょう。

procedure TForm1.Button1Click(Sender: TObject);
var bmp:TBitmap;
begin
  bmp:=TBitmap.Create;
  SampleGrabber1.GetBitmap(bmp);
  if SaveDialog1.Execute then
  begin
    bmp.SaveToFile(SaveDialog1.FileName);
  end;
  bmp.Free;
end;

その他必要なソースを追加する

以下赤字部分を追加しましょう。全ソースコードは以下です。実質入力するソースコードは十数行しかないです。

unit Unit1;

interface

uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
  Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls
  , DSPack, DXSUtil, DirectShow9;

type
  TForm1 = class(TForm)
    VideoWindow1: TVideoWindow;
    FilterGraph1: TFilterGraph;
    Filter1: TFilter;
    SampleGrabber1: TSampleGrabber;
    SaveDialog1: TSaveDialog;
    Button1: TButton;
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure Button1Click(Sender: TObject);
  private
    { Private 宣言 }
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.Button1Click(Sender: TObject);
var bmp:TBitmap;
begin
  bmp:=TBitmap.Create;
  SampleGrabber1.GetBitmap(bmp);
  if SaveDialog1.Execute then
  begin
    bmp.SaveToFile(SaveDialog1.FileName);
  end;
  bmp.Free;
end;

procedure TForm1.FormCreate(Sender: TObject);
var ICapB:ICaptureGraphBuilder2;
    VideoDevices:TSysDevEnum;       //取り込みビデオデバイスの列挙
begin
  VideoDevices:=TSysDevEnum.Create(CLSID_VideoInputDeviceCategory);
  Filter1.FilterGraph:=FilterGraph1;
  Filter1.BaseFilter.Moniker:=VideoDevices.GetMoniker(0);
  VideoWindow1.FilterGraph:=FilterGraph1;
  SampleGrabber1.FilterGraph:=FilterGraph1;
  FilterGraph1.ClearGraph;
  FilterGraph1.Mode:=gmCapture;
  FilterGraph1.Active:=True;

  ICapB:=FilterGraph1 as ICaptureGraphBuilder2;
  ICapB.RenderStream(@PIN_CATEGORY_PREVIEW,nil,Filter1 as IBaseFilter,
    SampleGrabber1 as IBaseFilter,VideoWindow1 as IBaseFilter);
  FilterGraph1.Play;
  VideoDevices.Free;
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
  FilterGraph1.Stop;
  FilterGraph1.Active:=False;
  FilterGraph1.ClearGraph;
end;

end.

保存して、USBカメラを接続して実行する

念のため「すべて保存」なり、SHIFT+Ctrl+Sを押すなりして保存しましょう。
そろそろ実行しますので、USBカメラをパソコンに取り付けましょう。
取り付けたら、実行ボタンを押して実行します。

「撮影」ボタンを押すと、USBカメラで撮影した画像をBMPとして保存できます。