DirectShowを利用して再生・その5

unit capt;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, ExtCtrls,
  ComCtrls,
  Menus,
  DirectShow9;

type
  TMyVMRMode = (vmOld, vmVMR7, vmVMR9);

const
  G_ciCAPTURE_BASICVIDEO_VMR9 = 0;
  G_ciCAPTURE_BASICVIDEO_VMR7 = 1;
  G_ciCAPTURE_BASICVIDEO_OLD  = 2;
  G_ciCAPTURE_MEDIADET        = 3;

type
  TForm_Capture = class(TForm)
    PopupMenu_Capture:        TPopupMenu;
    MenuItem_CaptureLine1:    TMenuItem;
    MenuItem_ShowForm:        TMenuItem;
    Image1:        TImage;
    Panel1:        TPanel;
    Button_Copy:   TButton;
    Button_SaveAs: TButton;
    ComboBox1:     TComboBox;
    StatusBar1:    TStatusBar;
    SaveDialog1:   TSaveDialog;
    procedure MenuItem_ShowFormClick      (Sender: TObject);
    procedure MenuItem_SelCaptureClick    (Sender: TObject);
    procedure MenuItem_BasicVideo_OldClick(Sender: TObject);
    procedure FormCreate        (Sender: TObject);
    procedure Button_CopyClick  (Sender: TObject);
    procedure Button_SaveAsClick(Sender: TObject);
    procedure ComboBox1Select   (Sender: TObject);
  private
    { Private 宣言 }
    procedure F_ShowMsg(AValue : array of Variant); overload;
    procedure F_ShowMsg(sValue : String);           overload;
    procedure F_CreateCaptureMenu;
    //IBasicVideo
    function  F_CaptureBasicVideo(sFileName : WideString; fTime : Double = 0; vmMode : TMyVMRMode = vmVMR9) : Boolean;
    //IMediaDet
    function  F_CaptureMediaDet(sFileName : WideString; fTime : Double = 0) : Boolean;
  public
    { Public 宣言 }
  end;

function  Capture(sFileName : WideString; fTime : Double) : Boolean;
procedure SetCaptureIndex(iIndex : Integer); //キャプチャ方法を指定
procedure CopyImage;  //クリップボードへコピー
procedure SaveImage;  //保存
procedure ShowForm;
procedure CloseForm;  //閉じる(破棄はしない)
procedure RleaseForm; //破棄

var
  Form_Capture: TForm_Capture;

implementation
uses
  ActiveX,
  Clipbrd;


{$R *.dfm}

procedure FreeMediaType(var AMediaType: TAMMediaType);
//http://msdn.microsoft.com/ja-jp/library/cc354534.aspx
begin
  if (AMediaType.cbFormat <> 0) then begin
    CoTaskMemFree(AMediaType.pbFormat);
    AMediaType.cbFormat := 0;
    AMediaType.pbFormat := nil;
    if (AMediaType.pUnk <> nil) then begin
      // pUnk は使用しない方がよいので不要だが、安全を期すため。
      AMediaType.pUnk := nil;
    end;
  end;
end;

procedure TForm_Capture.F_ShowMsg(AValue : array of Variant);
var
  ls_Arg : WideString;
  i      : Integer;
begin
  ls_Arg := '';
  for i := High(AValue) downto 0 do begin
    ls_Arg := WideString(VarAsType(AValue[i], varOleStr)) + ' ' + ls_Arg;
  end;

  StatusBar1.SimpleText := ls_Arg;
end;

procedure TForm_Capture.F_ShowMsg(sValue : String);
begin
  F_ShowMsg([sValue]);
end;

procedure TForm_Capture.MenuItem_SelCaptureClick(Sender: TObject);
var
  l_MenuItem : TMenuItem;
begin
  if not(Sender is TMenuItem) then begin
    Exit;
  end;
  l_MenuItem          := TMenuItem(Sender);
  l_MenuItem.Checked  := True;
  ComboBox1.ItemIndex := l_MenuItem.MenuIndex;
end;
procedure TForm_Capture.F_CreateCaptureMenu;
var
  i          : Integer;
  ls_Name    : String;
  l_MenuItem : TMenuItem;
begin
  if (ComboBox1.ItemIndex < 0) then begin
    ComboBox1.ItemIndex := 0;
  end;

  for i := ComboBox1.Items.Count-1 downto 0 do begin
    ls_Name    := Format('__%s_%d', [PopupMenu_Capture.Items.Name, i]);
    l_MenuItem := NewItem(
      ComboBox1.Items[i],       //Caption
      0,                        //ShortCut
      i = 0,                    //Checked
      True,                     //Enabled
      MenuItem_SelCaptureClick, //OnClickイベント
      0,                        //HelpContext
      ls_Name                   //Name
    );
    with l_MenuItem do begin
      RadioItem := True;
    end;
    PopupMenu_Capture.Items.Insert(0, l_MenuItem);
  end;
end;
procedure TForm_Capture.FormCreate(Sender: TObject);
begin
  Self.Icon    := Application.Icon;
  Image1.Align := alClient;
  F_CreateCaptureMenu;
end;

procedure TForm_Capture.Button_CopyClick(Sender: TObject);
begin
  Clipboard.Assign(Image1.Picture);
end;

procedure TForm_Capture.Button_SaveAsClick(Sender: TObject);
begin
  if (SaveDialog1.Execute) then
  begin
    Image1.Picture.Bitmap.SaveToFile(SaveDialog1.FileName);
  end;
end;

procedure TForm_Capture.ComboBox1Select(Sender: TObject);
begin
  PopupMenu_Capture.Items[ComboBox1.ItemIndex].Checked := True;
end;

procedure TForm_Capture.MenuItem_BasicVideo_OldClick(Sender: TObject);
var
  l_MenuItem : TMenuItem;
begin
  if not(Sender is TMenuItem) then
  begin
    Exit;
  end;

  l_MenuItem          := TMenuItem(Sender);
  l_MenuItem.Checked  := True;
  ComboBox1.ItemIndex := l_MenuItem.MenuIndex;
end;

procedure TForm_Capture.MenuItem_ShowFormClick(Sender: TObject);
begin
  Self.Show;
end;

function FloatToTime(fTime : TRefTime) : String;
//秒数から'0:00:30.020'のようなフォーマットに変換。
var
  li_Time, li_Hour, li_Min, li_Sec : Integer;
begin
  li_Time := Trunc(fTime);
  li_Hour := li_Time div 60 div 60;
  li_Min  := li_Time div 60 mod 60;
  li_Sec  := li_Time mod 60;
  Result  := Format('%d:%.2d:%.2d.%.3d', [li_Hour, li_Min, li_Sec, Trunc(Frac(fTime) * 1000)]);
end;

function TForm_Capture.F_CaptureBasicVideo(sFileName : WideString; fTime : Double = 0; vmMode : TMyVMRMode = vmVMR9) : Boolean;
{
http://www.geekpage.jp/programming/directshow/getcurrentimage.php
http://logsoku.com/thread/pc2.2ch.net/tech/1026666092/
http://forum.4programmers.net/Delphi_Pascal/123438-Delphi_IBasicVideo.GetCurrentImage_-_do_TBitmap
}
var
  li_Ret : HResult;
  ls_Msg : String;

  l_GraphBuilder  : IGraphBuilder;
  l_VideoRenderer : IBaseFilter;
  l_MediaControl  : IMediaControl;
  l_MediaPosition : IMediaPosition;
  l_BasicVideo    : IBasicVideo;
  l_VideoWindow   : IVideoWindow;

  lp_Buff     : PByte;
  li_BuffSize : Longint;
  l_Stream    : TMemoryStream;
  l_BmpHeader : TBitmapFileHeader;
  lp_BmpInfo  : PBitmapInfoHeader;
  li_Palette  : DWORD;
begin
  Result := False;
  ls_Msg := '';

  try
    //グラフ作成
    CoCreateInstance(
      CLSID_FilterGraph,
      nil,
      CLSCTX_INPROC,
      IID_IGraphBuilder,
      l_GraphBuilder
    );

    case vmMode of
      vmOld
      :begin
        F_ShowMsg('ビデオレンダラを利用してキャプチャを開始します');
        //旧ビデオレンダラ。
        CoCreateInstance(
          CLSID_VideoRenderer,
          nil,
          CLSCTX_INPROC,
          IID_IBaseFilter,
          l_VideoRenderer
        );
        l_GraphBuilder.AddFilter(l_VideoRenderer, 'Video Renderer');
      end;
      vmVMR7
      :begin
        //VMR7
        F_ShowMsg('VMR7を利用してキャプチャを開始します');
        CoCreateInstance(
          CLSID_VideoMixingRenderer,
          nil,
          CLSCTX_INPROC,
          IID_IBaseFilter,
          l_VideoRenderer
        );
        l_GraphBuilder.AddFilter(l_VideoRenderer, 'Video Renderer');
      end;
      vmVMR9
      :begin
        //VMR9
        F_ShowMsg('VMR9を利用してキャプチャを開始します');
        CoCreateInstance(
          CLSID_VideoMixingRenderer9,
          nil,
          CLSCTX_INPROC,
          IID_IBaseFilter,
          l_VideoRenderer
        );
        l_GraphBuilder.AddFilter(l_VideoRenderer, 'VMR9');
      end;
    end;

    //読み込み。
    F_ShowMsg(['読み込みを開始します', sFileName]);
    li_Ret := l_GraphBuilder.RenderFile(POLESTR(sFileName), nil);
    if not(Succeeded(li_Ret)) then begin
      ls_Msg := '読み込み失敗' + ' ' + sFileName;
      Exit;
    end;

    //非表示用。
    l_GraphBuilder.QueryInterface(IVideoWindow, l_VideoWindow);
    l_VideoWindow.put_AutoShow(False);
    l_VideoWindow := nil;
    //頭だし。
    F_ShowMsg(['キャプチャ位置調整', FloatToTime(fTime)]);
    l_GraphBuilder.QueryInterface(IMediaPosition, l_MediaPosition);
    l_MediaPosition.put_CurrentPosition(fTime);
    l_MediaPosition := nil;
    //ポーズ用。
    l_GraphBuilder.QueryInterface(IMediaControl, l_MediaControl);
    l_MediaControl.StopWhenReady;
    l_MediaControl := nil;

    //キャプチャ用。
    l_GraphBuilder.QueryInterface(IBasicVideo, l_BasicVideo);
    if (l_BasicVideo = nil) then begin
      Exit;
    end;
{
DirectShow9.pasのIBasicVideo.GetCurrentImageの宣言を↓のように書き換える必要あり。
//    function GetCurrentImage(var BufferSize: Longint; var pDIBImage): HResult; stdcall;
  function GetCurrentImage(var BufferSize: Longint; pDIBImage: Pointer): HResult; stdcall;
}
    li_Ret := l_BasicVideo.GetCurrentImage(li_BuffSize, nil);
    if not(Succeeded(li_Ret)) then begin
      ls_Msg := 'キャプチャサイズ取得失敗';
      Exit;
    end;
    GetMem(lp_Buff, li_BuffSize);
    try
      //BitmapInfoHeader+ビットマップ本体がバッファにコピーされる。
      F_ShowMsg(['キャプチャ中', li_BuffSize, 'Byte']);
      li_Ret := l_BasicVideo.GetCurrentImage(li_BuffSize, lp_Buff);
      if not(Succeeded(li_Ret)) then begin
        Exit;
      end;

      F_ShowMsg('ビットマップ変換中');
      lp_BmpInfo := PBitmapInfoHeader(lp_Buff);
      //BitmapFileHeader作成。
      FillChar(l_BmpHeader, SizeOf(l_BmpHeader), 0);
      l_BmpHeader.bfType := $4d42;
      l_BmpHeader.bfSize := SizeOf(l_BmpHeader) + li_BuffSize;
      //IMediaDetと違いRGB24に決めうちではないかも知れないのでパレット分も計算する。
      if  (lp_BmpInfo.biClrUsed   = 0)
      and (lp_BmpInfo.biBitCount <= 8)
      then begin
        li_Palette := (1 shl lp_BmpInfo.biBitCount)
      end else begin
        li_Palette := lp_BmpInfo.biClrUsed;
      end;
      l_BmpHeader.bfOffBits := SizeOf(l_BmpHeader) + lp_BmpInfo.biSize + (li_Palette * SizeOf(TRGBQuad));

      l_Stream := TMemoryStream.Create;
      try
        //ストリームにBitmapFileHeaderを書き込み。
        l_Stream.Write(l_BmpHeader, Sizeof(l_BmpHeader));
        //BitmapInfoHeaderとビットマップ本体を書き込み。
        l_Stream.Write(lp_Buff^, li_BuffSize);
        l_Stream.Position := 0;
        Image1.Picture.Bitmap.LoadFromStream(l_Stream);
        Result := True;
      finally
        l_Stream.Free;
      end;
    finally
      FreeMem(lp_Buff);
    end;
  finally
    l_GraphBuilder  := nil;
    l_VideoRenderer := nil;
    l_BasicVideo    := nil;
  end;

  if (Result) then begin
    F_ShowMsg('キャプチャ完了');
  end else begin
    F_ShowMsg(['キャプチャ失敗', ls_Msg, li_Ret]);
  end;
end;

function TForm_Capture.F_CaptureMediaDet(sFileName : WideString; fTime : Double = 0) : Boolean;
{
http://logsoku.com/thread/pc2.2ch.net/tech/1026666092/
http://msdn.microsoft.com/ja-jp/library/cc356940.aspx
http://msdn.microsoft.com/ja-jp/library/cc356932.aspx
http://msdn.microsoft.com/ja-jp/library/cc356944.aspx

ffdshowとMP4Splitterの組み合わせによってMP4ファイルが最初のフレームの画像しか取れ
なかったりエラーで取得できなかったりする。
Haali MP4Splitterとffdshowの組み合わせだと最初のフレームの画像しか取得できないよう。
}
var
  li_Ret      : HResult;
  ls_Msg      : String;
  l_IMediaDet : IMediaDet;
  l_MediaType : TAMMediaType;
  l_VideoInfo : TVideoInfoHeader;
  i           : Longint;
  li_Count    : Longint;
  lp_Buff     : PByte;
  li_BuffSize : Longint;
  l_Stream    : TMemoryStream;
  l_BmpHeader : TBitmapFileHeader;
begin
  Result := False;
  ls_Msg := '';
  li_Ret := 0;

  try
    try
      CoCreateInstance(
        CLSID_MediaDet,
        nil,
        CLSCTX_INPROC_SERVER,
        IMediaDet,
        l_IMediaDet
      );
      F_ShowMsg(['読み込みを開始します', sFileName]);
      li_Ret := l_IMediaDet.put_Filename(sFileName);
      if not(Succeeded(li_Ret)) then begin
        ls_Msg := '読み込み失敗' + ' ' + sFileName;
        Abort;
      end;
      l_IMediaDet.get_OutputStreams(li_Count);
      for i := 0 to li_Count-1 do begin
        //ストリーム指定。
        l_IMediaDet.put_CurrentStream(i);
        l_IMediaDet.get_StreamMediaType(l_MediaType);
        try
          if  (IsEqualGUID(l_MediaType.majortype,  MEDIATYPE_Video)) //ビデオ
          and (IsEqualGUID(l_MediaType.formattype, FORMAT_VideoInfo))
          then begin
            //VIDEOINFOHEADER
            l_VideoInfo := PVideoInfoHeader(l_MediaType.pbFormat)^;
            li_Ret      := l_IMediaDet.GetBitmapBits(fTime, @li_BuffSize, nil, l_VideoInfo.bmiHeader.biWidth, l_VideoInfo.bmiHeader.biHeight);
            if not(Succeeded(li_Ret)) then begin
              ls_Msg := 'キャプチャサイズ取得失敗';
              Abort;
            end;
            GetMem(lp_Buff, li_BuffSize);
            try
              //BitmapInfoHeader+ビットマップ本体がバッファにコピーされる。
              F_ShowMsg(['キャプチャ中', li_BuffSize, 'Byte']);
              if not(Succeeded(l_IMediaDet.GetBitmapBits(fTime, @li_BuffSize, lp_Buff, l_VideoInfo.bmiHeader.biWidth, l_VideoInfo.bmiHeader.biHeight))) then begin
                Abort;
              end;

              F_ShowMsg('ビットマップ変換中');
              //BitmapFileHeader作成。
              FillChar(l_BmpHeader, SizeOf(l_BmpHeader), 0);
              l_BmpHeader.bfType    := $4d42;
              l_BmpHeader.bfSize    := SizeOf(l_BmpHeader) + li_BuffSize;
              //IMediaDetで得られる画像はRGB24と決まっているのでパレットはない。
              l_BmpHeader.bfOffBits := SizeOf(l_BmpHeader) + PBitmapInfoHeader(lp_Buff).biSize;

              l_Stream := TMemoryStream.Create;
              try
                //ストリームにBitmapFileHeaderを書き込み。
                l_Stream.Write(l_BmpHeader, Sizeof(l_BmpHeader));
                //BitmapInfoHeaderとビットマップ本体を書き込み。
                l_Stream.Write(lp_Buff^, li_BuffSize);
                l_Stream.Position := 0;
                Image1.Picture.Bitmap.LoadFromStream(l_Stream);
                Result := True;
              finally
                l_Stream.Free;
              end;
            finally
              FreeMem(lp_Buff);
            end;
            Break;
          end;
        finally
          FreeMediaType(l_MediaType);
        end;
      end;
    finally
      l_IMediaDet := nil;
    end;
  except
    //キャプチャ失敗。
  end;

  if (Result) then begin
    F_ShowMsg('キャプチャ完了');
  end else begin
    F_ShowMsg(['キャプチャ失敗', ls_Msg, li_Ret]);
  end;
end;

function _FormExists : Boolean;
var
  i : Integer;
begin
  if not(Assigned(Form_Capture)) then begin
    Result := False;
  end else begin
    Result := False;
    for i := 0 to Screen.FormCount-1 do begin
      if (Screen.Forms[i] is TForm_Capture) then begin
        Result := True;
        Break;
      end;
    end;
  end;
end;
procedure _CreateForm;
begin
  if not(_FormExists) then begin
    Form_Capture := TForm_Capture.Create(Application);
  end;
end;

function Capture(sFileName : WideString; fTime : Double) : Boolean;
{キャプチャ実行。
sFileNameはファイル名。WideStringなのでユニコードな文字を含むファイル名もOK。
fTimeは秒数。例えば90を指定すると1分30秒の位置の映像をキャプチャする。
}
begin
  //Form_Captureが作成されていなければ作成する。
  _CreateForm;

  if not(Form_Capture.Visible) then begin
    Form_Capture.Show;
  end;

  case Form_Capture.ComboBox1.ItemIndex of
    G_ciCAPTURE_MEDIADET
    :begin
      //IMediaDetインターフェース版。
      //Haali MP4Splitterを使用している場合fTimeの値にかかわらず頭の1フレーム目し
      //かキャプチャできないこともある。
      Result := Form_Capture.F_CaptureMediaDet(sFileName, fTime);
    end;
    G_ciCAPTURE_BASICVIDEO_OLD
    :begin
      Result := Form_Capture.F_CaptureBasicVideo(sFileName, fTime, vmOld);
    end;
    G_ciCAPTURE_BASICVIDEO_VMR7
    :begin
      Result := Form_Capture.F_CaptureBasicVideo(sFileName, fTime, vmVMR7);
    end;
    else
    begin
      //デフォルトはVMR9
      Result := Form_Capture.F_CaptureBasicVideo(sFileName, fTime, vmVMR9);
    end;
  end;

  if (Result) then begin
    Form_Capture.Image1.Refresh;
    Form_Capture.Show;
  end;
end;

procedure SetCaptureIndex(iIndex : Integer);
{キャプチャ方法を指定。
iIndexは0ベースのインデックスを指定。
iIndexがコンボボックスのリストの範囲外の場合両端に張り付いて指定を行う。
-1なら0、リストのCountが4でiIndexが6や10の指定なら(0ベースなので)3の指定となる。
}
var
  l_ComboBox : TComboBox;
begin
  //Form_Captureが作成されていなければ作成する。
  _CreateForm;

  l_ComboBox := Form_Capture.ComboBox1;
  if (iIndex < 0) then
  begin
    iIndex := 0;
  end else if (iIndex >= l_ComboBox.Items.Count) then
  begin
    iIndex := l_ComboBox.Items.Count -1;
  end;
  l_ComboBox.ItemIndex := iIndex;
end;

procedure CopyImage;
begin
  //Form_Captureが作成されていなければ作成する。
  _CreateForm;
  Form_Capture.Button_CopyClick(nil);
end;

procedure SaveImage;
begin
  //Form_Captureが作成されていなければ作成する。
  _CreateForm;
  Form_Capture.Button_SaveAsClick(nil);
end;

procedure ShowForm;
begin
  //Form_Captureが作成されていなければ作成する。
  _CreateForm;
  Form_Capture.Show;
end;

procedure CloseForm;
//閉じる(破棄はしない)
begin
  if (_FormExists) then begin
    Form_Capture.Close;
  end;
end;

procedure RleaseForm;
//破棄。
begin
  if (_FormExists) then begin
    Form_Capture.Release;
  end;
end;


end.

procedure TForm1.Button_CaptureClick(Sender: TObject);
//ビデオ映像からビットマップを取得。
var
  lf_Pos : Double;
begin
  if (F_MediaPosition = nil) then begin
    Exit;
  end;

  //現在再生中のレンダラーとは別のレンダラー（グラフも別）から取得。
  Button_Capture.Enabled := False;
  try
    F_MediaPosition.get_CurrentPosition(lf_Pos);
    //キャプチャ。
    if (capt.Capture(F_sFileName, lf_Pos)) then begin
      //コピー。
      capt.CopyImage;
    end;
  finally
    Button_Capture.Enabled := True;
  end;
end;

procedure TForm1.WMDisplayChange(var Msg: TMessage);
//TScreenのMonitorsプロパティがディスプレイの変更に追随しない不具合の回避のため。
begin
  Self.Monitor;
end;