unit myBmpCaptureEx; //{$DEFINE _DEBUG} //{$DEFINE CAPTURE_STEP} //{$DEFINE GDIPLUS} { 2013-03-19: ・フレームのヒントを若干変更。 2012-05-12: ・サンプルグラバフィルタが繋がらなかった場合にもキャプチャできるようにした。 2011-11-14: ・キャプチャ後フォームの幅を広げてキャプチャフレーム数を増やして次のフレームから 　キャプチャすると冒頭からキャプチャされる不具合を修正。 　フレーム数を増やした場合増えた分のフレームの時間は0のままなため。 ・ミュートの状態を設定ファイルに持つようにした。 ・方向キーの左と右を「再生/フレーム移動」からキャプチャしたフレーム画像の移動に 　変更。 2011-10-10:サブフォームとして作成した際にデフォルトで画像を保存のイベントをnilに 　セットしていたため保存ができなくなっていた不具合を修正。 　何故こんな設定にしていたのか我ながら不明。 　もしかしたらwallawから呼び出していた時の名残りなのかも。 } interface uses Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, ComCtrls, ExtCtrls, ActnList, Buttons, Grids, ImgList, Menus, ToolWin, DirectShow9, InterfaceUtilsUnit, myComboBox, myFileDialog, myGraphic, myIniFile, myTrackBar; type T_MyOnBufferCB = procedure(Sender: TObject; fSampleTime: Double; pBuffer: PByte; BufferLen: Longint) of object; T_MySampleGrabberCB = class(TInterfacedBase, ISampleGrabberCB) private FOnBufferCB : T_MyOnBufferCB; function SampleCB(SampleTime: Double; pSample: IMediaSample): HResult; stdcall; function BufferCB(SampleTime: Double; pBuffer: PByte; BufferLen: Longint): HResult; stdcall; public property OnBufferCB : T_MyOnBufferCB read FOnBufferCB write FOnBufferCB; end; T_TimeBitmap = class(TMyBitmap) private FfTime : Double; public constructor Create; override; property Time : Double read FfTime write FfTime; end; const //イベントを受け取るためのユニークなメッセージ番号 WM_GRAPH_NOTIFY = (WM_APP +109); gcsMEDIACAPTURE_ARG = 'CAPTURE'; //????????????? type TApp_TOOLBmpCaptureEx = class(TForm) ActionList1: TActionList; Action_FileOpen: TAction; Action_FileSaveAs: TAction; Action_FileSaveFormat: TAction; Action_FileSaveBmp: TAction; Action_FileSaveGif: TAction; Action_FileSaveJpeg: TAction; Action_FileSavePng: TAction; Action_FileSaveTiff: TAction; Action_FileClose: TAction; Action_FileExit: TAction; Action_EditCopy: TAction; Action_Program: TAction; Action_ProgramRun: TAction; Action_ProgramAdd: TAction; Action_ProgramDel: TAction; Action_ProgramForeground: TAction; Action_Capture: TAction; Action_CaptureNow: TAction; Action_CaptureBack: TAction; Action_CaptureNext: TAction; Action_CaptureSampleGrabber: TAction; Action_PlayPlayPause: TAction; Action_PlayReplay: TAction; Action_PlaySkipNext: TAction; Action_PlaySkipBack: TAction; Action_PlayFrameBack: TAction; Action_PlayFrameNext: TAction; Action_PlaySkip1minBack: TAction; Action_PlaySkip1minNext: TAction; Action_PlayPlay: TAction; Action_PlayPause: TAction; Action_PlayHome: TAction; Action_PlayEnd: TAction; Action_PlayStop: TAction; Action_PlayRate: TAction; Action_PlayRate_10: TAction; Action_PlayRate_09: TAction; Action_PlayRate_07: TAction; Action_PlayRate_05: TAction; Action_PlayRate_01: TAction; Action_PlayMute: TAction; Action_FrameBack: TAction; Action_FrameNext: TAction; Action_ZoomUp: TAction; Action_ZoomDown: TAction; Action_Zoom100: TAction; Action_ZoomAlwaysFit: TAction; Action_ShowToolBar: TAction; Action_ShowStatusBar: TAction; Action_ShowHintPopup: TAction; Action_ShowTimeVerbose: TAction; Action_HelpVersionInfo: TAction; Menu_Main: TMainMenu; MenuItem_File: TMenuItem; MenuItem_FileOpen: TMenuItem; MenuItem_FileSaveAs: TMenuItem; MenuItem_FileSaveFormat: TMenuItem; MenuItem_FileSaveBmp: TMenuItem; MenuItem_FileSaveGif: TMenuItem; MenuItem_FileSaveJpeg: TMenuItem; MenuItem_FileSavePng: TMenuItem; MenuItem_FileSaveTiff: TMenuItem; MenuItem_FileLine1: TMenuItem; MenuItem_FileClose: TMenuItem; MenuItem_FileLine2: TMenuItem; MenuItem_Program: TMenuItem; MenuItem_ProgramAdd: TMenuItem; MenuItem_ProgramDel: TMenuItem; MenuItem_ProgramLine1: TMenuItem; MenuItem_ProgramForeground: TMenuItem; MenuItem_ProgramLine2: TMenuItem; MenuItem_FileLine3: TMenuItem; MenuItem_FileExit: TMenuItem; MenuItem_Edit: TMenuItem; MenuItem_EditCopy: TMenuItem; MenuItem_EditLine1: TMenuItem; MenuItem_CaptureNow: TMenuItem; MenuItem_CaptureBack: TMenuItem; MenuItem_CaptureNext: TMenuItem; MenuItem_Play: TMenuItem; MenuItem_PlayPlayPause: TMenuItem; MenuItem_PlayReplay: TMenuItem; MenuItem_PlayLine1: TMenuItem; MenuItem_PlayHome: TMenuItem; MenuItem_PlayEnd: TMenuItem; MenuItem_PlaySkipBack: TMenuItem; MenuItem_PlaySkipNext: TMenuItem; MenuItem_PlayLine2: TMenuItem; MenuItem_PlaySkip1minBack: TMenuItem; MenuItem_PlaySkip1minNext: TMenuItem; MenuItem_FrameBack: TMenuItem; MenuItem_FrameNext: TMenuItem; MenuItem_PlayLine3: TMenuItem; MenuItem_Rate: TMenuItem; MenuItem_Rate_10: TMenuItem; MenuItem_Rate_09: TMenuItem; MenuItem_Rate_07: TMenuItem; MenuItem_Rate_05: TMenuItem; MenuItem_PlayLine4: TMenuItem; MenuItem_PlayMute: TMenuItem; MenuItem_Bmp: TMenuItem; MenuItem_ZoomUp: TMenuItem; MenuItem_ZoomDown: TMenuItem; MenuItem_Zoom100: TMenuItem; MenuItem_ZoomFit: TMenuItem; MenuItem_Opt: TMenuItem; MenuItem_CaptureSampleGrabber: TMenuItem; MenuItem_OptLine1: TMenuItem; MenuItem_ShowToolBar: TMenuItem; MenuItem_ShowStatusBar: TMenuItem; MenuItem_ShowHintPopup: TMenuItem; MenuItem_OptLine2: TMenuItem; MenuItem_ShowTimeVerbose: TMenuItem; MenuItem_Help: TMenuItem; MenuItem_HelpVersionInfo: TMenuItem; Menu_OpenHistory: TPopupMenu; Menu_ProgramDel: TPopupMenu; Popumenu_PlayRate: TPopupMenu; MenuItem_PRate_10: TMenuItem; MenuItem_PRate_09: TMenuItem; MenuItem_PRate_07: TMenuItem; MenuItem_PRate_05: TMenuItem; Popupmenu_Image: TPopupMenu; MenuItemImage_Edit_Copy: TMenuItem; MenuItemImage_Line1: TMenuItem; MenuItemImage_File_SaveAs: TMenuItem; MenuItemImage_Line2: TMenuItem; MenuItemImage_File_SaveBmp: TMenuItem; MenuItemImage_File_SaveGif: TMenuItem; MenuItemImage_File_SaveJpeg: TMenuItem; MenuItemImage_File_SavePng: TMenuItem; MenuItemImage_File_SaveTiff: TMenuItem; MenuItemImage_Line3: TMenuItem; MenuItemImage_Zoom100: TMenuItem; MenuItemImage_ZoomAutoSize: TMenuItem; Popupmenu_Save: TPopupMenu; MenuItemSave_File_SaveBmp: TMenuItem; MenuItemSave_File_SaveGif: TMenuItem; MenuItemSave_File_SaveJpeg: TMenuItem; MenuItemSave_File_SavePng: TMenuItem; MenuItemSave_File_SaveTiff: TMenuItem; Popupmenu_Video: TPopupMenu; MenuItemImage_CaptureNow: TMenuItem; MenuItemImage_CaptureBack: TMenuItem; MenuItemImage_CaptureNext: TMenuItem; MenuItemVideo_Line1: TMenuItem; MenuItemVideo_PlayPlayPause: TMenuItem; MenuItemVideo_PlayFrameBack: TMenuItem; MenuItemVideo_PlayFrameNext: TMenuItem; MenuItemVideo_PlaySkip1minBack: TMenuItem; MenuItemVideo_PlaySkip1min: TMenuItem; Menu_Program: TPopupMenu; ToolBar_Main: TToolBar; ToolButton_FileOpen: TToolButton; ToolButton_FileSaveAs: TToolButton; ToolButton_MainSpc1: TToolButton; ToolButton_EditCopy: TToolButton; ToolButton_MainSpc2: TToolButton; ToolButton_Zoom100: TToolButton; ToolButton_MainSpc3: TToolButton; ToolButton_ProgramForeground: TToolButton; ToolButton_ProgramAdd: TToolButton; ToolButton_MainSpc4: TToolButton; ToolButton_ShowToolBar: TToolButton; ToolButton_ShowStatusBar: TToolButton; ToolButton_Program: TToolButton; ToolButton_ShowPopupHint: TToolButton; ToolButton_ZoomFit: TToolButton; ToolButton_ZoomUp: TToolButton; ToolButton_ZoomDown: TToolButton; Panel_VideoBase: TPanel; Panel_Video: TPanel; Label_Size: TLabel; Panel_BitmapBase: TPanel; Label_Stretch: TLabel; Grid_Bitmap: TDrawGrid; Image_Bitmap: TImage; Panel_Frame: TPanel; Shape_FrameTop: TShape; Panel_FBack: TPanel; Button_Capture_Back: TSpeedButton; Panel_FNext: TPanel; Button_Capture_Next: TSpeedButton; Panel_0: TPanel; Label_0: TLabel; Image_0: TImage; Panel_1: TPanel; Label_1: TLabel; Image_1: TImage; Panel_2: TPanel; Label_2: TLabel; Image_2: TImage; Panel_3: TPanel; Label_3: TLabel; Image_3: TImage; Panel_4: TPanel; Label_4: TLabel; Image_4: TImage; Panel_Bottom: TPanel; TrackBar_Seek: TMyTrackBar; Shape1: TShape; Panel_Control: TPanel; ToolBar_Control: TToolBar; Button_Play_PlayPause: TToolButton; Button_Play_Skip1minBack: TToolButton; Button_Play_FrameBack: TToolButton; Button_Play_FrameNext: TToolButton; Button_Play_Skip1minNext: TToolButton; Button_Spc1: TToolButton; Button_Play_Mute: TToolButton; Button_Spc2: TToolButton; Button_Capture_Now: TToolButton; Label_Time: TLabel; Label_Duration: TLabel; StatusBar_Hint: TStatusBar; Panel_Program: TPanel; ComboBox_Program: TComboBox; ImageList1: TImageList; ImageList_Program: TImageList; Dialog_Open: TMyOpenFileDialog; Dialog_SaveAs: TMySaveFileDialog; Dialog_Program: TMyOpenFileDialog; ColorDialog1: TColorDialog; Timer_Time: TTimer; Timer_Capture: TTimer; procedure Action_FileOpenExecute (Sender: TObject); procedure Action_FileCloseExecute (Sender: TObject); procedure Action_FileSaveAsExecute (Sender: TObject); procedure Action_FileSaveBmpExecute (Sender: TObject); procedure Action_FileWallpaperExecute (Sender: TObject); procedure Action_FileExitExecute (Sender: TObject); procedure Action_ProgramRunExecute (Sender: TObject); procedure Action_ProgramAddExecute (Sender: TObject); procedure Action_ProgramDelExecute (Sender: TObject); procedure Action_EditCopyExecute (Sender: TObject); procedure Action_CaptureExecute (Sender: TObject); procedure Action_CaptureBackExecute (Sender: TObject); procedure Action_CaptureSampleGrabberExecute(Sender: TObject); procedure Action_PlayPlayPauseExecute (Sender: TObject); procedure Action_PlayPlayExecute (Sender: TObject); procedure Action_PlayPauseExecute (Sender: TObject); procedure Action_PlayStopExecute (Sender: TObject); procedure Action_PlayReplayExecute (Sender: TObject); procedure Action_PlaySkipBackExecute (Sender: TObject); procedure Action_PlayFrameBackExecute (Sender: TObject); procedure Action_PlayRate_10Execute (Sender: TObject); procedure Action_PlayMuteExecute (Sender: TObject); procedure Action_FrameBackExecute (Sender: TObject); procedure Action_Zoom100Execute (Sender: TObject); procedure Action_ZoomAlwaysFitExecute (Sender: TObject); procedure Action_ZoomUpExecute (Sender: TObject); procedure Action_ZoomDownExecute (Sender: TObject); procedure Action_ShowToolBarExecute (Sender: TObject); procedure Action_ShowStatusBarExecute (Sender: TObject); procedure Action_ShowHintPopupExecute (Sender: TObject); procedure Action_HelpVersionInfoExecute (Sender: TObject); procedure actNop (Sender: TObject); procedure MenuItem_OpenHistoryClick(Sender: TObject); procedure MenuItem_AdvancedDrawItem(Sender: TObject; ACanvas: TCanvas; ARect: TRect; State: TOwnerDrawState); procedure MenuItem_DrawItem (Sender: TObject; ACanvas: TCanvas; ARect: TRect; Selected: Boolean); procedure MenuItem_MeasureItem (Sender: TObject; ACanvas: TCanvas; var Width, Height: Integer); procedure FormCreate (Sender: TObject); procedure FormClose (Sender: TObject; var Action: TCloseAction); procedure FormDestroy (Sender: TObject); procedure FormResize (Sender: TObject); procedure FormKeyUp (Sender: TObject; var Key: Word; Shift: TShiftState); procedure FormMouseWheel(Sender: TObject; Shift: TShiftState; WheelDelta: Integer; MousePos: TPoint; var Handled: Boolean); // procedure ComboBox_ProgramDrawItem (Control: TWinControl; Index: Integer; Rect: TRect; State: TOwnerDrawState); procedure Image_0Click (Sender: TObject); procedure Image_0DblClick (Sender: TObject); procedure Image_BitmapDblClick (Sender: TObject); procedure Image_BitmapMouseDown (Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); procedure Image_BitmapMouseMove (Sender: TObject; Shift: TShiftState; X, Y: Integer); procedure Image_BitmapMouseUp (Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); procedure Grid_BitmapMouseWheelDown(Sender: TObject; Shift: TShiftState; MousePos: TPoint; var Handled: Boolean); procedure Grid_BitmapMouseWheelUp (Sender: TObject; Shift: TShiftState; MousePos: TPoint; var Handled: Boolean); procedure TrackBar_SeekMouseDown (Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); procedure TrackBar_SeekMouseMove (Sender: TObject; Shift: TShiftState; X, Y: Integer); procedure TrackBar_SeekMouseUp (Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); procedure Timer_TimeTimer (Sender: TObject); procedure Timer_CaptureTimer (Sender: TObject); private { Private 宣言 } FGraphBuilder : IGraphBuilder; FVideoRenderer : IBaseFilter; FVideoDecoder : IBaseFilter; FSampleGrabberFilter : IBaseFilter; FSampleGrabberCB : T_MySampleGrabberCB; FSampleGrabber : ISampleGrabber; FMediaPosition : IMediaPosition; FfDuration : TRefTime; FfAudioTime : TRefTime; FfVideoTime : TRefTime; FfStepTime : TRefTime; FfCaptureTime : TRefTime; FfAvgTimePerFrame : TRefTime; FbThrough : Boolean; FbPause : Boolean; FbCapture : Boolean; FbPauseAndCapture : Boolean; FiImageIndex : Integer; FiBuffSize : Longint; FpBuff : PByte; FiBuffCount : Integer; FBitmap : array of T_TimeBitmap; FiFrameIndex : Integer; //選択キャプチャフレームのインデックス FiMuteImageIndex : Integer; //ミュートボタンのイメージのImageIndex FsFileName : WideString; FfMediaPosition : TRefTime; FbMediaPlay : Boolean; FbResume : Boolean; FbSampleGrabber : Boolean; //サンプルグラバーのコールバックを利用してキャプチャするのか Fb_ffdshow : Boolean; //ffdshowがグラフに追加されているか //サブフォームモード FbSubFormMode : Boolean; //サブフォームモードで作成されたか //イベント通知のためのメッセージ番号を受け取れるようにする FMediaEventEx : IMediaEventEx; // FbStopped : Boolean; procedure WMGraphNotify (var Msg: TMessage); message WM_GRAPH_NOTIFY; //ディスプレイ設定の変更 procedure WMDisplayChange(var Msg: TMessage); message WM_DISPLAYCHANGE; procedure WMDropFiles (var Msg: TWMDropFiles); message WM_DROPFILES; procedure WMSysCommand (var Msg: TWMSysCommand); message WM_SYSCOMMAND; procedure WMExitSizeMove (var Msg: TMessage); message WM_EXITSIZEMOVE; procedure FAddOpenHistory(sFileName: WideString); procedure FCaptureStep(fPosition: TRefTime; iStep: Integer); procedure FConnectSampleGrabber; procedure FSampleGrabberBuffer(Sender: TObject; SampleTime: Double; pBuffer: PByte; BufferLen: Integer); procedure FCreate_ffdshow; procedure FCreateProgramMenu; procedure FGetBitmap; function FGetCapturedTime(AImage: TImage): TRefTime; function FGetFrameIndex: Integer; function FGetFrameRate: String; function FGetFrameMaxCount: Integer; function FGetImage(iIndex : Integer) : TImage; function FGetLabel(iIndex : Integer) : TLabel; function FGetStepLimit(fPos: TRefTime): TRefTime; function FGetStepTime(iStep : Integer): TRefTime; procedure FImageSave(sFileName: WideString); function FIsStepEnd: Boolean; procedure FOpen(sFileName: WideString); procedure FSetFrameCount; procedure FSetMediaPosition(fPos : TRefTime); procedure FSetPanelColor(APanel : TPanel); procedure FSetStretchCaption; procedure FSetSubForm;//(ASaveEvent: TNotifyEvent; APopupMenu: TPopupMenu); procedure FStep(iStep: Integer); public { Public 宣言 } constructor CreateSubForm(AOwner: TComponent);// ASaveEvent: TNotifyEvent; ASaveMenu: TPopupMenu); procedure PauseAndCapture(sFileName: WideString; fTime: TRefTime = 0); procedure LoadIni(AIniFile: TMyIniFile); overload; procedure SaveIni(AIniFile: TMyIniFile); overload; function LoadIni: Boolean; overload; procedure SaveIni; overload; property IsSubForm: Boolean read FbSubFormMode; end; var App_TOOLBmpCaptureEx: TApp_TOOLBmpCaptureEx; procedure CreateForm(AOwner: TComponent);// ASaveEvent: TNotifyEvent = nil; ASaveMenu: TPopupMenu = nil); procedure ShowForm; //表示 procedure CloseForm; //閉じる(破棄はしない) procedure RleaseForm; //破棄 procedure Capture(sFileName : WideString; fTime : TRefTime = 0); procedure CopyImage; //クリップボードへコピー procedure SaveImage; //保存 const G_ciFILESAVE_BMP = 1; G_ciFILESAVE_GIF = 2; G_ciFILESAVE_JPEG = 3; G_ciFILESAVE_PNG = 4; G_ciFILESAVE_TIFF = 5; implementation uses {$IFDEF _DEBUG} myDebug, myDebugDShow, {$ENDIF} ActiveX, BaseClass, Clipbrd, CommCtrl, ShellAPI, DSUtil, myControl, myDragAndDrop, myDShow, myDShowType, myFile, {$IFDEF GDIPLUS} myGDIPlus, {$ENDIF} myGIFImage, myHelpVersionInfo, myImage, myList, myMenu, myMessageBox, myNum, myParam, myShortCut, mySize, myWStrings, myWindow; {$R *.dfm} const F_ciTRACKPOS = 10; //10倍。0.1秒毎に移動可能。 F_ciBUFFMIN = 5; //一度にキャプチャするフレームの最小の数 F_ciBITCOUNT = 24; F_ciHISTORY = 10; //開いたファイルの履歴 { T_TimeBitmap } constructor T_TimeBitmap.Create; begin inherited; FfTime := -1; //-1の場合はまだキャプチャしてないことをあらわす end; function T_MySampleGrabberCB.SampleCB(SampleTime: Double; pSample: IMediaSample): HResult; stdcall; //使用しない begin Result := E_NOTIMPL; end; function T_MySampleGrabberCB.BufferCB(SampleTime: Double; pBuffer: PByte; BufferLen: Integer): HResult; stdcall; begin if Assigned(FOnBufferCB) then begin FOnBufferCB(Self, SampleTime, pBuffer, BufferLen); end; Result := S_OK; end; procedure TApp_TOOLBmpCaptureEx.FSampleGrabberBuffer(Sender: TObject; SampleTime: Double; pBuffer: PByte; BufferLen: Integer); procedure _GetBitmap(ABitmap: TBitmap); var l_BitmapInfo : TBitmapInfo; li_Ret : Integer; begin if (Failed(FSampleGrabber.GetCurrentBuffer(FiBuffSize, FpBuff))) then begin Exit; end; FillChar(l_BitmapInfo, SizeOf(l_BitmapInfo), 0); with l_BitmapInfo.bmiHeader do begin biSize := SizeOf(l_BitmapInfo); biWidth := ABitmap.Width; biHeight := ABitmap.Height; biBitCount := F_ciBITCOUNT; biPlanes := 1; biCompression := BI_RGB; end; ABitmap.Canvas.Lock; try li_Ret := SetDIBitsToDevice( ABitmap.Canvas.Handle, 0, 0, ABitmap.Width, ABitmap.Height, 0, 0, 0, ABitmap.Height, FpBuff, l_BitmapInfo, DIB_RGB_COLORS ); finally ABitmap.Canvas.Unlock; end; if (li_Ret <> ABitmap.Height) then begin //キャプチャ失敗 end; end; var l_MediaControl : IMediaControl; begin FfVideoTime := SampleTime; if (gfnbIsInsideRange(FiImageIndex, 0, FiBuffCount -1)) then begin if (FiBuffSize <> BufferLen) and (BufferLen > 0) then begin FiBuffSize := BufferLen; ReallocMem(FpBuff, FiBuffSize); end; if (SampleTime >= FfStepTime) then begin _GetBitmap(FBitmap[FiImageIndex]); FBitmap[FiImageIndex].Time := FfVideoTime; Inc(FiImageIndex); if (FiImageIndex >= FiBuffCount) or (FfVideoTime > FfDuration - FfAvgTimePerFrame * 1.5) then begin if (FbPause) then begin // Action_Play_PauseExecute(nil); //多分これが原因で落ちる try FGraphBuilder.QueryInterface(IMediaControl, l_MediaControl); l_MediaControl.Pause; finally l_MediaControl := nil; end; end; FiImageIndex := -1; //タイマー内でビットマップをイメージに表示する end; end; end; if (FfVideoTime > FfAudioTime) then begin //ビデオのフレームが音声に先行するようならウェイトを入れて調整する。 Sleep(100); end; if (Timer_Time.Enabled = False) and not(TrackBar_Seek.Touched) then begin //トラックバーのつまみの表示調整。 //つまみを動かした後一瞬元の位置に戻ってしまうのを防ぐため。 Timer_Time.Enabled := True; end; end; procedure TApp_TOOLBmpCaptureEx.Timer_TimeTimer(Sender: TObject); //現在位置表示。 procedure _CleanUp; begin Image_0Click(Image_0); // Action_Edit_CopyExecute(nil); Action_CaptureNow.Enabled := True; Action_CaptureBack.Enabled := Action_CaptureNow.Enabled; Action_CaptureNext.Enabled := Action_CaptureNow.Enabled; Action_PlayPlayPause.Enabled := Action_CaptureNow.Enabled; Action_PlayReplay.Enabled := Action_CaptureNow.Enabled; Action_PlayHome.Enabled := Action_CaptureNow.Enabled; Action_PlayEnd.Enabled := Action_CaptureNow.Enabled; Action_PlaySkipBack.Enabled := Action_CaptureNow.Enabled; Action_PlaySkipNext.Enabled := Action_CaptureNow.Enabled; Action_PlaySkip1minBack.Enabled := Action_CaptureNow.Enabled; Action_PlaySkip1minNext.Enabled := Action_CaptureNow.Enabled; Action_PlayFrameBack.Enabled := Action_CaptureNow.Enabled; Action_PlayFrameNext.Enabled := Action_CaptureNow.Enabled; Panel_Frame.Enabled := Action_CaptureNow.Enabled; TrackBar_Seek.Enabled := Action_CaptureNow.Enabled; Action_FileSaveAs.Enabled := Action_CaptureNow.Enabled; Action_FileSaveFormat.Enabled := Action_FileSaveAs.Enabled; Action_FileSaveBmp.Enabled := Action_FileSaveAs.Enabled; Action_FileSaveGif.Enabled := Action_FileSaveAs.Enabled; Action_FileSaveJpeg.Enabled := Action_FileSaveAs.Enabled; Action_FileSavePng.Enabled := Action_FileSaveAs.Enabled; Action_FileSaveTiff.Enabled := Action_FileSaveAs.Enabled; Action_EditCopy.Enabled := Action_FileSaveAs.Enabled; FfStepTime := -1; { if (FbPause) then begin Action_PlayPlayPause.ImageIndex := Action_PlayPlay.ImageIndex; end; } end; var i : Integer; l_Image : TImage; l_Label : TLabel; begin if (Assigned(FMediaPosition)) then begin FMediaPosition.get_CurrentPosition(FfAudioTime); //必須 if not(FbSampleGrabber) then begin FfVideoTime := FfAudioTime; end; if (FbCapture) and (FiImageIndex = -1) then begin if (FbSampleGrabber) then begin for i := 0 to High(FBitmap) do begin l_Image := gfnFindControl(Panel_Frame, Format('Image_%d', [i])) as TImage; if (l_Image = nil) then begin Continue; end; l_Label := gfnFindControl(Panel_Frame, Format('Label_%d', [i])) as TLabel; if (l_Label = nil) then begin Continue; end; l_Image.Picture.Bitmap.Assign(FBitmap[i]); l_Image.Refresh; if (FBitmap[i].Time >= 0) then begin l_Label.Caption := gfnsSecToTimeStr(FBitmap[i].Time, 3); end else begin l_Label.Caption := ''; end; end; end; FbCapture := False; _CleanUp; end; if (FbThrough) or (TrackBar_Seek.Touched) then begin //トラックバーのスライダーの位置を変更しない end else begin //トラックバーのスライダーを触っていなかったらスライダーを現在位置に移動させる。 TrackBar_Seek.Position := Trunc(FfVideoTime * F_ciTRACKPOS); //ビデオフレームの時間 end; if (Action_ShowTimeVerbose.Checked) then begin Label_Time.Caption := Format('[映像%s][音声%s][差%s]%s', [ gfnsSecToTimeStr(FfVideoTime, 3), //ビデオフレームの位置 gfnsSecToTimeStr(FfAudioTime, 3), //音声の位置 gfnsSecToTimeStr(FfAudioTime - FfVideoTime, 3), //音声とビデオフレームの差 '' ]); end else begin Label_Time.Caption := Format('%s', [gfnsSecToTimeStr(FfVideoTime, 3)]); //ビデオフレームの位置 end; end; end; function TApp_TOOLBmpCaptureEx.FGetFrameMaxCount: Integer; begin Result := Trunc((Panel_Frame.ClientWidth - Panel_FBack.Width - Panel_FNext.Width) / Panel_0.Width); end; procedure TApp_TOOLBmpCaptureEx.FSetFrameCount; var li_OldCount : Integer; li_NewCount : Integer; i : Integer; l_Panel : TPanel; l_Image : TImage; l_Label : TLabel; begin li_OldCount := Length(FBitmap); li_NewCount := gfniMax([F_ciBUFFMIN, FGetFrameMaxCount]); //最低5フレームは確保する if (li_OldCount <> li_NewCount) then begin //キャプチャフレームの数に変動があった if (li_NewCount > li_OldCount) then begin //作成 SetLength(FBitmap, li_NewCount); for i := li_OldCount to li_NewCount -1 do begin FBitmap[i] := T_TimeBitmap.Create; if (i >= F_ciBUFFMIN) then begin //5フレーム分はあらかじめ作成済みなので6フレーム目から作成 l_Panel := TPanel.Create(Panel_Frame); l_Panel.Name := gfnsAvailableName('Panel'); l_Panel.Parent := Panel_Frame; l_Panel.SetBounds(Panel_Frame.Width, Panel_0.Top, Panel_0.Width, Panel_0.Height); l_Panel.Align := Panel_0.Align; l_Panel.BevelOuter := Panel_0.BevelOuter; l_Panel.Caption := ''; l_Panel.Caption := l_Panel.Name; l_Panel.DoubleBuffered := Panel_0.DoubleBuffered; l_Panel.OnClick := Panel_0.OnClick; l_Image := TImage.Create(l_Panel); l_Image.Name := gfnsAvailableName('Image'); l_Image.Parent := l_Panel; l_Image.SetBounds(Image_0.Left, Image_0.Top, Image_0.Width, Image_0.Height); l_Image.Anchors := Image_0.Anchors; l_Image.Proportional := Image_0.Proportional; l_Image.Stretch := Image_0.Stretch; l_Image.Center := Image_0.Center; l_Image.Hint := Image_0.Hint; l_Image.OnClick := Image_0.OnClick; l_Image.OnDblClick := Image_0.OnDblClick; gpcBmpSizeSet(l_Image.Picture.Bitmap, Image_0.Picture.Bitmap.Width, Image_0.Picture.Bitmap.Height); l_Label := TLabel.Create(l_Panel); l_Label.Name := gfnsAvailableName('Label'); l_Label.Parent := l_Panel; l_Label.SetBounds(Label_0.Left, Label_0.Top, Label_0.Width, Label_0.Height); l_Label.AutoSize := Label_0.AutoSize; l_Label.Caption := ''; l_Label.Anchors := Label_0.Anchors; l_Label.Alignment := Label_0.Alignment; l_Label.Layout := Label_0.Layout; l_Label.ShowAccelChar := Label_0.ShowAccelChar; l_Label.OnClick := Label_0.OnClick; if (li_OldCount > 0) and (FBitmap[li_OldCount -1] <> nil) then begin l_Image.Picture.Bitmap.Assign(FBitmap[li_OldCount -1]); FBitmap[i].Assign(FBitmap[li_OldCount -1]); if (FBitmap[i].Time >= 0) then begin FBitmap[i].Time := FBitmap[li_OldCount -1].Time; l_Label.Caption := gfnsSecToTimeStr(FBitmap[i].Time, 3); end; end; end; end; end else begin //解放 for i := High(FBitmap) downto li_NewCount do begin FreeAndNil(FBitmap[i]); l_Panel := gfnFindControl(Panel_Frame, Format('Panel_%d', [i])) as TPanel; if (l_Panel = nil) then begin Continue; end else begin FreeAndNil(l_Panel); end; end; SetLength(FBitmap, li_NewCount); end; end; FiBuffCount := Length(FBitmap); Panel_FBack.BringToFront; //AIU; Panel_FNext.BringToFront; Action_CaptureBack.Caption := Format('前の%dフレームをキャプチャ(&B)', [FiBuffCount]); Action_CaptureNext.Caption := Format('次の%dフレームをキャプチャ(&N)', [FiBuffCount]); Action_CaptureBack.Hint := Format('取得フレームの%:0dフレーム前からキャプチャ ([Shift]キー併用で%:1dフレーム前から%:0dフレームをキャプチャ)', [FiBuffCount, FiBuffCount * 2]); Action_CaptureNext.Hint := Format('取得フレームの次の%:0dフレームをキャプチャ ([Shift]キー併用で%:1dフレーム後からキャプチャ)', [FiBuffCount, FiBuffCount * 2]); end; //------------------------------------------------------------------------------ procedure TApp_TOOLBmpCaptureEx.FSetSubForm;//(ASaveEvent: TNotifyEvent; APopupMenu: TPopupMenu); //サブフォームモード begin FbSubFormMode := True; MenuItem_Help.Visible := False; Action_PlayMute.Checked := True; Self.Caption := '静止画キャプチャ'; Action_FileExit.Caption := '閉じる(&C)'; Action_FileExit.Hint := '閉じる'; Action_HelpVersionInfo.ShortCut := 0; { if (@Action_FileSaveAs.OnExecute <> nil) then begin Action_FileSaveAs.OnExecute := ASaveEvent; end; if (ToolButton_FileSaveAs.DropdownMenu <> nil) then begin ToolButton_FileSaveAs.DropdownMenu := APopupMenu; end; } end; procedure TApp_TOOLBmpCaptureEx.PauseAndCapture(sFileName : WideString; fTime : TRefTime = 0); begin FbPauseAndCapture := True; FOpen(sFileName); if (FMediaPosition <> nil) then begin FCaptureStep(fTime, 0); //NG! Action_Capture_Now.OnExecute(Action_Capture_Now); Action_CaptureExecute(nil); end; end; constructor TApp_TOOLBmpCaptureEx.CreateSubForm(AOwner : TComponent);// ASaveEvent: TNotifyEvent; ASaveMenu: TPopupMenu); begin Self.Create(AOwner); FSetSubForm;//(ASaveEvent, ASaveMenu); end; procedure TApp_TOOLBmpCaptureEx.FormCreate(Sender: TObject); var i : Integer; l_Option : TMyParamOption; lf_Time : TRefTime; ls_File : WideString; begin if not(IsSubForm) then begin Self.Caption := gfnsProductNameGet; Application.Title := Self.Caption; end; Self.Icon := Application.Icon; Self.Constraints.MinWidth := Panel_FBack.Width + (Panel_0.Width * F_ciBUFFMIN) + Panel_FNext.Width + (Self.Width - Self.ClientWidth); Self.ClientHeight := 366; Self.ClientWidth := 504; Dialog_Open.InitialDir := gfnsMyVideoPathGet; Dialog_SaveAs.InitialDir := gfnsMyPicturePathGet; Dialog_Program.InitialDir := gfnsProgramFilesPathGet; // F_sWallpaperIniDir := gfnsMyPicturePathGet; {$IFNDEF GDIPLUS} Dialog_SaveAs.Filter := 'BMP (*.bmp)|*.bmp|GIF (*.gif)|*.gif|JPEG (*.jpg;*.jpeg)|*.jpg;*.jpeg|すべてのファイル (*.*)|*.*'; Action_FileSavePng.Visible := False; Action_FileSaveTiff.Visible := False; {$ENDIF} FSampleGrabberCB := T_MySampleGrabberCB.Create; FSampleGrabberCB.OnBufferCB := FSampleGrabberBuffer; TrackBar_Seek.Frequency := TrackBar_Seek.Frequency * F_ciTRACKPOS; Panel_Video.Color := clWhite; // Panel_Bitmap.Color := clWhite; Image_Bitmap.Parent := Grid_Bitmap; Grid_Bitmap.DoubleBuffered := True; // Panel_Bitmap.DoubleBuffered := True; //ちらつきを抑えるため Panel_VideoBase.ParentColor := True; Panel_BitmapBase.ParentColor := True; Panel_Control.DoubleBuffered := True; FiMuteImageIndex := Action_PlayMute.ImageIndex; if not(LoadIni) then begin //設定ファイルを読み込まなかった場合の処理 Action_ProgramDel.Enabled := False; end; FSetFrameCount; //初期化しているだけ Action_FileCloseExecute(nil); if (ParamW.Count > 1) then begin //ParamW.ParamStr[0]は実行ファイル名なので0からではなく1から始める lf_Time := 0; ls_File := ''; for i := 1 to ParamW.Count -1 do begin l_Option := ParamW.OptionParam[i]; if (l_Option.IsOption) then begin if (l_Option.CompareOption('T')) then begin //Time '1:23' lf_Time := gfnfTimeStrToSec(l_Option.ValueString); end else if (l_Option.CompareOption('S')) then begin //Second '83'; lf_Time := l_Option.ValueFloat; end; end else begin ls_File := ParamW.Params[i]; end; end; if (ls_File <> '') then begin PauseAndCapture(ls_File, lf_Time); end; end; DragAcceptFiles(Self.Handle, True); end; procedure TApp_TOOLBmpCaptureEx.FormClose(Sender: TObject; var Action: TCloseAction); begin FbPauseAndCapture := False; Action_FileCloseExecute(nil); end; procedure TApp_TOOLBmpCaptureEx.FormDestroy(Sender: TObject); var i : Integer; begin DragAcceptFiles(Self.Handle, False); SaveIni; Action_FileCloseExecute(nil); FreeMem(FpBuff); //ここでないとエラーになってしまう謎 for i := 0 to High(FBitmap) do begin FreeAndNil(FBitmap[i]); end; FSampleGrabberCB.Free; end; procedure TApp_TOOLBmpCaptureEx.FormMouseWheel(Sender: TObject; Shift: TShiftState; WheelDelta: Integer; MousePos: TPoint; var Handled: Boolean); begin //デフォルトのマウスホイール動作をキャンセルする Handled := True; end; procedure TApp_TOOLBmpCaptureEx.FormKeyUp(Sender: TObject; var Key: Word; Shift: TShiftState); //キーアップ begin case Key of VK_SPACE :begin if (ssShift in Shift) then begin Action_PlayReplayExecute(nil); end else begin Action_PlayPlayPauseExecute(nil); end; end; VK_HOME :begin Action_PlaySkipBackExecute(Action_PlayHome); end; VK_END :begin Action_PlaySkipBackExecute(Action_PlayEnd); end; VK_PRIOR :begin Action_PlaySkipBackExecute(Action_PlaySkipBack); end; VK_NEXT :begin Action_PlaySkipBackExecute(Action_PlaySkipNext); end; VK_LEFT :begin // Action_PlayFrameBackExecute(Action_PlayFrameBack); //キャプチャフレーム移動 Action_FrameBackExecute(Action_FrameBack); end; VK_RIGHT :begin // Action_PlayFrameBackExecute(Action_PlayFrameNext); //キャプチャフレーム移動 Action_FrameBackExecute(Action_FrameNext); end; end; Key := 0; end; procedure TApp_TOOLBmpCaptureEx.FSetStretchCaption; var ls_Value : String; li_Width : Integer; li_Height : Integer; begin ls_Value := ''; if (FVideoRenderer <> nil) then begin if (Image_Bitmap.Picture.Width > 0) or (Image_Bitmap.Picture.Height > 0) then begin gpcFitToVideoSizeGet(Image_Bitmap.Picture.Bitmap, Image_Bitmap.Width, Image_Bitmap.Height, li_Width, li_Height); ls_Value := Format('%.0f%%', [(li_Width / Image_Bitmap.Picture.Bitmap.Width) * 100]); end; end; if (ls_Value <> '') then begin Label_Stretch.Caption := Format('[ %s ]', [ls_Value]); end else begin Label_Stretch.Caption := ''; end; end; procedure TApp_TOOLBmpCaptureEx.WMExitSizeMove(var Msg: TMessage); //http://www.geocities.jp/fjtkt/program/2007_0002.html begin FSetFrameCount; end; procedure TApp_TOOLBmpCaptureEx.WMSysCommand(var Msg: TWMSysCommand); begin //myDebug.gpcDebug('WMSysCommand', Msg.CmdType); case Msg.CmdType of SC_MAXIMIZE, 61490, 61458, 61730 :begin inherited; FSetFrameCount; end; else begin inherited; end; end; end; procedure TApp_TOOLBmpCaptureEx.FormResize(Sender: TObject); const lci_SPC = 8; function _GetHeight : Integer; begin Result := Self.ClientHeight - Panel_Frame.Height - Panel_Bottom.Height - lci_SPC * 2; if (ToolBar_Main.Visible) then begin Dec(Result, ToolBar_Main.Height); end; if (StatusBar_Hint.Visible) then begin Dec(Result, StatusBar_Hint.Height); end; end; function _GetTop : Integer; begin Result := lci_SPC; if (ToolBar_Main.Visible) then begin Inc(Result, ToolBar_Main.Height); end; end; var li_Left : Integer; li_Top : Integer; li_Width : Integer; li_Height : Integer; l_VideoWindow : IVideoWindow; begin if (Application.Terminated) then begin Exit; end; li_Width := Self.ClientWidth - lci_SPC * 3; li_Height := _GetHeight; Panel_VideoBase.SetBounds(lci_SPC, _GetTop, li_Width div 2, li_Height); Panel_BitmapBase.SetBounds( Panel_VideoBase.Left + Panel_VideoBase.Width + lci_SPC, Panel_VideoBase.Top, Panel_VideoBase.Width, li_Height ); if (FVideoRenderer <> nil) and (Image_Bitmap.Picture.Bitmap.Width > 0) and (Image_Bitmap.Picture.Bitmap.Height > 0) then begin li_Width := Panel_Video.Width; li_Height := Trunc(li_Width * (Image_Bitmap.Picture.Bitmap.Height / Image_Bitmap.Picture.Bitmap.Width)); if (li_Height > Panel_Video.Height) then begin li_Height := Panel_Video.Height; li_Width := Trunc(li_Height * (Image_Bitmap.Picture.Bitmap.Width / Image_Bitmap.Picture.Bitmap.Height)); end; li_Left := (Panel_Video.Width - li_Width) div 2; li_Top := (Panel_Video.Height - li_Height) div 2; //ビデオのサイズをPanel_Videoに合わせる。 FGraphBuilder.QueryInterface(IVideoWindow, l_VideoWindow); l_VideoWindow.SetWindowPosition(li_Left, li_Top, li_Width, li_Height); l_VideoWindow := nil; end; end; procedure TApp_TOOLBmpCaptureEx.WMDisplayChange(var Msg: TMessage); //TScreenのMonitorsプロパティがディスプレイの変更に追随しない不具合の回避のためだけ。 begin Self.Monitor; end; function TApp_TOOLBmpCaptureEx.FGetImage(iIndex : Integer) : TImage; begin Result := gfnFindControl(Panel_Frame, Format('Image_%d', [iIndex])) as TImage; end; function TApp_TOOLBmpCaptureEx.FGetLabel(iIndex : Integer) : TLabel; begin Result := gfnFindControl(Panel_Frame, Format('Label_%d', [iIndex])) as TLabel; end; procedure TApp_TOOLBmpCaptureEx.FGetBitmap; //現在のイメージをキャプチャ var l_BasicVideo : IBasicVideo; li_Ret : HResult; lp_BmpInfo : PBitmapInfoHeader; l_BmpHeader : TBitmapFileHeader; li_Palette : DWORD; l_Stream : TMemoryStream; l_Image : TImage; l_Label : TLabel; begin l_Image := FGetImage(FiImageIndex); if (l_Image = nil) then begin Exit; end; l_Label := FGetLabel(FiImageIndex); if (l_Label = nil) then begin Exit; end; try FGraphBuilder.QueryInterface(IBasicVideo, l_BasicVideo); { DirectShow9.pasのIBasicVideo.GetCurrentImageの宣言を↓のように書き換える必要あり function GetCurrentImage(var BufferSize: Longint; var pDIBImage): HResult; stdcall; function GetCurrentImage(var BufferSize: Longint; pDIBImage: Pointer): HResult; stdcall; } if (FiBuffSize < 0) then begin if not(Succeeded(l_BasicVideo.GetCurrentImage(FiBuffSize, nil))) then begin Exit; end; ReallocMem(FpBuff, FiBuffSize); end; FMediaPosition.get_CurrentPosition(FfVideoTime); //BitmapInfoHeader+ビットマップ本体がバッファにコピーされる。 li_Ret := l_BasicVideo.GetCurrentImage(FiBuffSize, FpBuff); if not(Succeeded(li_Ret)) then begin Exit; end; lp_BmpInfo := PBitmapInfoHeader(FpBuff); //BitmapFileHeader作成 FillChar(l_BmpHeader, SizeOf(l_BmpHeader), 0); l_BmpHeader.bfType := $4d42; l_BmpHeader.bfSize := SizeOf(l_BmpHeader) + FiBuffSize; //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(FpBuff^, FiBuffSize); l_Stream.Position := 0; // FBitmap[FiImageIndex].LoadFromStream(l_Stream); // FBitmap[FiImageIndex].Time := FfVideoTime; l_Image.Picture.Bitmap.LoadFromStream(l_Stream); l_Image.Refresh; if (FfVideoTime >= 0) then begin l_Label.Caption := gfnsSecToTimeStr(FfVideoTime, 3); end else begin l_Label.Caption := ''; end; finally l_Stream.Free; end; finally l_BasicVideo := nil; end; { l_Image.Picture.Bitmap.Assign(FBitmap[FiImageIndex]); l_Image.Refresh; if (FBitmap[FiImageIndex].Time >= 0) then begin l_Label.Caption := gfnsSecToTimeStr(FBitmap[FiImageIndex].Time, 3); end else begin l_Label.Caption := ''; end; } end; procedure TApp_TOOLBmpCaptureEx.WMGraphNotify(var Msg: TMessage); //イベント処理 var li_EventCode : Longint; li_Param1 : Longint; li_Param2 : Longint; l_MediaEventEx : IMediaEventEx; {$IFNDEF CAPTURE_STEP} // l_MediaControl : IMediaControl; // lf_Pos : TRefTime; {$ENDIF} begin if (FMediaEventEx = nil) then begin Exit; end; l_MediaEventEx := FMediaEventEx; // イベントを全て取得 while (Succeeded(l_MediaEventEx.GetEvent(li_EventCode, li_Param1, li_Param2, 0))) do begin {$IFDEF _DEBUG} myDebugDShow.gpcDS_MediaEvent(li_EventCode, li_Param1, li_Param2); {$ENDIF} try case (li_EventCode) of EC_COMPLETE :begin //再生が終わりに来た Action_PlayPauseExecute(nil); end; {$IFDEF CAPTURE_STEP} EC_STEP_COMPLETE :begin if not(FbSampleGrabber) and (FbCapture) then begin FGetBitmap; Inc(FiImageIndex); if (FiImageIndex > High(FBitmap)) then begin FiImageIndex := -1; Timer_TimeTimer(nil); end else begin FStep(1); Beep; end; end; end; {$ENDIF} end; finally l_MediaEventEx.FreeEventParams(li_EventCode, li_Param1, li_Param2); end; end; { if (F_bStopped) then begin l_MediaEventEx := nil; F_bStopped := False; end; } end; procedure TApp_TOOLBmpCaptureEx.Action_EditCopyExecute(Sender: TObject); //編集/コピー begin if (Image_Bitmap.Picture.Bitmap.Width > 0) and (Image_Bitmap.Picture.Bitmap.Height > 0) then begin try Clipboard.Assign(Image_Bitmap.Picture.Bitmap); except gpcShowMessage('クリップボードへコピーできませんでした'); end; end; end; procedure TApp_TOOLBmpCaptureEx.Action_FileCloseExecute(Sender: TObject); procedure _ClearBitmap(AImage : TImage); var l_Bitmap : TBitmap; begin l_Bitmap := TBitmap.Create; try gpcBmpSizeSet(l_Bitmap, AImage.Picture.Bitmap.Width, AImage.Picture.Bitmap.Height); AImage.Picture.Bitmap.Assign(l_Bitmap); gpcBmpSizeSet(AImage.Picture.Bitmap); finally l_Bitmap.Free; end; end; var l_SampleGrabber : ISampleGrabber; l_MediaControl : IMediaControl; i : Integer; l_Image : TImage; l_Label : TLabel; begin if (IsSubForm) then begin Self.Caption := Format('%s - %s', [gfnsProductNameGet, '静止画キャプチャ']); end else begin Self.Caption := gfnsProductNameGet; end; if (FSampleGrabberFilter <> nil) then begin FSampleGrabberFilter.QueryInterface(ISampleGrabber, l_SampleGrabber); l_SampleGrabber.SetCallback(nil, 1); l_SampleGrabber := nil; end; Timer_Time.Enabled := False; TrackBar_Seek.Enabled := False; TrackBar_Seek.Position := 0; Label_Time.Caption := ''; Label_Duration.Caption := ''; FsFileName := ''; Action_FileClose.Enabled := False; Action_FileSaveAs.Enabled := Action_FileClose.Enabled; Action_FileSaveFormat.Enabled := Action_FileSaveAs.Enabled; Action_FileSaveBmp.Enabled := Action_FileSaveAs.Enabled; Action_FileSaveGif.Enabled := Action_FileSaveAs.Enabled; Action_FileSaveJpeg.Enabled := Action_FileSaveAs.Enabled; Action_FileSavePng.Enabled := Action_FileSaveAs.Enabled; Action_FileSaveTiff.Enabled := Action_FileSaveAs.Enabled; Action_PlayReplay.Enabled := Action_FileClose.Enabled; Action_PlayHome.Enabled := Action_FileClose.Enabled; Action_PlayEnd.Enabled := Action_FileClose.Enabled; Action_PlaySkipBack.Enabled := Action_FileClose.Enabled; Action_PlaySkipNext.Enabled := Action_FileClose.Enabled; Action_PlaySkip1minBack.Enabled := Action_FileClose.Enabled; Action_PlaySkip1minNext.Enabled := Action_FileClose.Enabled; Action_PlayFrameBack.Enabled := Action_FileClose.Enabled; Action_PlayFrameNext.Enabled := Action_FileClose.Enabled; Action_EditCopy.Enabled := Action_FileClose.Enabled; Action_CaptureNow.Enabled := Action_FileClose.Enabled; Action_CaptureBack.Enabled := Action_FileClose.Enabled; Action_CaptureNext.Enabled := Action_FileClose.Enabled; Action_Zoom100.Enabled := Action_FileClose.Enabled; Action_ZoomUp.Enabled := Action_FileClose.Enabled; Action_ZoomDown.Enabled := Action_FileClose.Enabled; FbSampleGrabber := False; Fb_ffdshow := False; FbPause := False; FbCapture := False; FfStepTime := 0; FiImageIndex := -1; //0〜2でなければキャプチャを始めない if not(FbResume) then begin _ClearBitmap(Image_Bitmap); for i := 0 to High(FBitmap) do begin //AIU if (FBitmap[i] = nil) then begin Continue; end; FBitmap[i].Time := -1; gpcBmpSizeSet(FBitmap[i]); l_Image := gfnFindControl(Panel_Frame, Format('Image_%d', [i])) as TImage; if (l_Image <> nil) then begin _ClearBitmap(l_Image); end; l_Label := gfnFindControl(Panel_Frame, Format('Label_%d', [i])) as TLabel; if (l_Label <> nil) then begin l_label.Caption := ''; end; end; // FreeMem(FpBuff); //NG エラーになる FSetPanelColor(nil); Panel_Frame.Hide; Panel_Frame.Show; Panel_Frame.Enabled := False; Label_Size.Caption := ''; FSetStretchCaption; Image_Bitmap.Align := alClient; end; if (FGraphBuilder <> nil) then begin try FGraphBuilder.QueryInterface(IMediaControl, l_MediaControl); l_MediaControl.Stop; finally l_MediaControl := nil; end; DisconnectFilters(FGraphBuilder); FGraphBuilder := nil; end; FVideoRenderer := nil; FVideoDecoder := nil; FMediaPosition := nil; FSampleGrabberFilter := nil; // Action_PlayPlayPause.ImageIndex := Action_PlayPlay.ImageIndex; end; procedure TApp_TOOLBmpCaptureEx.Action_FileExitExecute(Sender: TObject); begin Close; end; procedure TApp_TOOLBmpCaptureEx.Action_FileWallpaperExecute(Sender: TObject); //壁紙設定ウィンドウを開く begin // myWallpaper_main.CreateForm(Application); // App_TOOLWallpaper.AddBmp(Image_Bitmap.Picture.Bitmap); // App_TOOLWallpaper.Show; end; procedure TApp_TOOLBmpCaptureEx.FCreate_ffdshow; begin //ffdshowを優先して利用する if (Succeeded(CreateBaseFilter(FVideoDecoder, CLSID_LegacyAmFilterCategory, 'ffdshow Video Decoder'))) and (Succeeded(FGraphBuilder.AddFilter(FVideoDecoder, 'ffdshow Video Decoder'))) then begin Fb_ffdshow := True; ConnectFilters(FGraphBuilder, FVideoDecoder, FVideoRenderer); end; end; procedure TApp_TOOLBmpCaptureEx.FConnectSampleGrabber; var l_MediaType : TAMMediaType; begin //SampleGrabberを接続するフォーマットを指定。 FillChar(l_MediaType, SizeOf(l_MediaType), 0); l_MediaType.majortype := MEDIATYPE_Video; l_MediaType.subtype := MEDIASUBTYPE_RGB24; //コメントアウトするとキャプチャできない l_MediaType.formattype := FORMAT_VideoInfo; FSampleGrabber.SetMediaType(l_MediaType); end; procedure TApp_TOOLBmpCaptureEx.FOpen(sFileName : WideString); //開く var l_VideoWindow : IVideoWindow; l_BasicVideo : IBasicVideo; l_MediaControl : IMediaControl; li_Width : Integer; li_Height : Integer; li_Size : Integer; li_Mod : Integer; i : Integer; l_Image : TImage; l_MediaType : TAMMediaType; li_Ret : HResult; ls_ErrMsg : WideString; begin Action_FileCloseExecute(nil); FsFileName := sFileName; try if not(gfnbFileExists(FsFileName)) then begin gpcShowMessage(FsFileName + #13'ファイルが存在しません'); Exit; end; //GraphBuilderはその都度作成しないと再生速度を変更して開始できない //グラフ作成 CreateGraphBuilder(FGraphBuilder); //ビデオレンダラを生成 { if (gfniOSMajorVersionGet >= 6) then begin CreateVMR9(FVideoRenderer, FGraphBuilder); end else begin CreateVMR7(FVideoRenderer, FGraphBuilder); end; } CreateVMR9(FVideoRenderer, FGraphBuilder); //ffdshowを優先して利用する FCreate_ffdshow; if (Action_CaptureSampleGrabber.Checked) then begin //SampleGrabber(Filter)を生成 CreateSampleGrabber(FSampleGrabberFilter, FSampleGrabber, FGraphBuilder); FConnectSampleGrabber; end; //タイトルバーにファイル名を表示 Caption := gfnsWideToAnsi(gfnsFileNameGet(FsFileName)); //読み込み if (Failed(FGraphBuilder.RenderFile(PWideChar(FsFileName), nil))) then begin gpcShowMessage(FsFileName + #13'は開けません'); Exit; end; //イベント通知ウィンドウをセット。 // FGraphBuilder.QueryInterface(IMediaEventEx, FMediaEventEx); // FMediaEventEx.SetNotifyWindow(Self.Handle, WM_GRAPH_NOTIFY, 0); //ビデオのサイズを取得 try FGraphBuilder.QueryInterface(IBasicVideo, l_BasicVideo); li_Width := 0; li_Height := 0; l_BasicVideo.get_VideoWidth (li_Width); l_BasicVideo.get_VideoHeight(li_Height); if (li_Width <= 0) or (li_Height <= 0) then begin gpcShowMessage('メディアにビデオ映像がありません'); Label_Size.Caption := ''; Exit; end; finally l_BasicVideo := nil; end; Action_FileClose.Enabled := True; Action_PlayPlay.Enabled := Action_FileClose.Enabled; Action_PlayReplay.Enabled := Action_FileClose.Enabled; Action_PlayHome.Enabled := Action_FileClose.Enabled; Action_PlayEnd.Enabled := Action_FileClose.Enabled; Action_PlaySkipBack.Enabled := Action_FileClose.Enabled; Action_PlaySkipNext.Enabled := Action_FileClose.Enabled; Action_PlaySkip1minBack.Enabled := Action_FileClose.Enabled; Action_PlaySkip1minNext.Enabled := Action_FileClose.Enabled; Action_PlayFrameBack.Enabled := Action_FileClose.Enabled; Action_PlayFrameNext.Enabled := Action_FileClose.Enabled; Action_CaptureNow.Enabled := (li_Width > 0) and (li_Height > 0); Action_Zoom100.Enabled := Action_CaptureNow.Enabled; Action_ZoomUp.Enabled := Action_CaptureNow.Enabled; Action_ZoomDown.Enabled := Action_CaptureNow.Enabled; //ビットマップのサイズをセット gpcBmpSizeSet(Image_Bitmap.Picture.Bitmap, li_Width, li_Height); for i := 0 to High(FBitmap) do begin gpcBmpSizeSet(FBitmap[i], li_Width, li_Height); l_Image := gfnFindControl(Panel_Frame, Format('Image_%d', [i])) as TImage; if (l_Image <> nil) then begin gpcBmpSizeSet(l_Image.Picture.Bitmap, li_Width, li_Height); end; end; //フレームレート取得。 Label_Size.Caption := Format('[ %dx%d %sfps %dミリ秒 ]', [li_Width, li_Height, FGetFrameRate, gfniRound(FfAvgTimePerFrame * 1000)]); Timer_Time.Interval := gfniMin([Trunc(FfAvgTimePerFrame * 1000), 30]); if (Timer_Time.Interval = 0) then begin Timer_Time.Interval := 30; end; if (Action_CaptureSampleGrabber.Checked) then begin FillChar(l_MediaType, SizeOf(l_MediaType), 0); try li_Ret := FSampleGrabber.GetConnectedMediaType(l_MediaType); FbSampleGrabber := Succeeded(li_Ret); if not(FbSampleGrabber) then begin //ffdshow ビデオデコーダの設定で「オーバーレイ」の「出力」の「RGB24」のチェックが外れているとうまくいかない。 ls_ErrMsg := '静止画キャプチャの設定がうまくいきませんでした'#13'キャプチャの間隔が飛び飛びになるかも知れません'; if (Fb_ffdshow) then begin ls_ErrMsg := ls_ErrMsg + #13 + 'ffdshowのビデオでコーダの設定で「オーバーレイ」の「出力」の「RGB24」にチェックを入れることで改善されるかも知れません'; end; gpcShowMessage(ls_ErrMsg); end; finally FreeMediaType(@l_MediaType); end; end else begin FbSampleGrabber := False; end; if (FbSampleGrabber) then begin li_Size := li_Width * (F_ciBITCOUNT div 8); //24ビットカラー li_Mod := li_Size mod SizeOf(DWORD); if (li_Mod <> 0) then begin //DWORDにアライメントされているための調整 // Inc(li_Size, SizeOf(DWORD) - li_Mod); li_Size := gfniRoundUp(li_Size / SizeOf(DWORD)) * SizeOf(DWORD); end; FiBuffSize := li_Height * li_Size; ReallocMem(FpBuff, FiBuffSize); if (Action_CaptureSampleGrabber.Checked) then begin FSampleGrabber.SetCallback(FSampleGrabberCB, 1); FSampleGrabber.SetBufferSamples(True); end; end else begin try FGraphBuilder.QueryInterface(IBasicVideo, l_BasicVideo); { DirectShow9.pasのIBasicVideo.GetCurrentImageの宣言を↓のように書き換える必要あり function GetCurrentImage(var BufferSize: Longint; var pDIBImage): HResult; stdcall; function GetCurrentImage(var BufferSize: Longint; pDIBImage: Pointer): HResult; stdcall; } if (Succeeded(l_BasicVideo.GetCurrentImage(FiBuffSize, nil))) then begin ReallocMem(FpBuff, FiBuffSize); end else begin FiBuffSize := -1; end; finally l_BasicVideo := nil; end; end; //パネル上にビデオを表示。 FGraphBuilder.QueryInterface(IVideoWindow, l_VideoWindow); l_VideoWindow.put_Owner(Panel_Video.Handle); l_VideoWindow.put_WindowStyle(WS_CHILD or WS_CLIPSIBLINGS); l_VideoWindow.put_MessageDrain(Panel_Video.Handle); //マウスメッセージを拾えるようにする l_VideoWindow.SetWindowForeground(OAFALSE); //タスクバーがフラッシュするのを防ぐ l_VideoWindow := nil; FormResize(nil); //ミュート Action_PlayMuteExecute(nil); //長さ取得 FGraphBuilder.QueryInterface(IMediaPosition, FMediaPosition); FfDuration := 0; FMediaPosition.get_Duration(FfDuration); //この後CurrentPositionが変わってしまうことがある TrackBar_Seek.Max := Trunc(FfDuration * F_ciTRACKPOS); Label_Duration.Caption := Format('/%s', [gfnsSecToTimeStr(FfDuration, 3)]); //再生速度セット Action_PlayRate_10Execute(nil); //開いた履歴に追加 FAddOpenHistory(FsFileName); if (FbResume) then begin //FMediaPosition.put_CurrentPosition(FGetStepLimit(FfMediaPosition)); FSetMediaPosition(FfMediaPosition); Timer_TimeTimer(nil); if (FbMediaPlay) then begin Action_PlayPlayExecute(nil); end else begin FGraphBuilder.QueryInterface(IMediaControl, l_MediaControl); l_MediaControl.StopWhenReady; end; end else begin //再生開始 if (Action_FileOpen.Visible) then begin Action_PlayReplayExecute(nil); end else begin Action_PlayPauseExecute(nil); end; end; TrackBar_Seek.Enabled := True; finally FbResume := False; FfMediaPosition := 0; FbMediaPlay := False; end; end; procedure TApp_TOOLBmpCaptureEx.WMDropFiles(var Msg: TWMDropFiles); var l_Drop: TMyDropFiles; begin l_Drop := TMyDropFiles.Create(Msg, Self); try FOpen(l_Drop.Files[0]); finally l_Drop.Free; end; end; procedure TApp_TOOLBmpCaptureEx.MenuItem_OpenHistoryClick(Sender: TObject); begin if not(Sender is TMenuItem) then begin Exit; end; FOpen(TMenuItem(Sender).Hint); end; procedure TApp_TOOLBmpCaptureEx.FAddOpenHistory(sFileName: WideString); var i : Integer; ls_File : String; ls_Name : String; ls_Caption : String; begin if (sFileName = '') then begin Exit; end; ls_File := UpperCase(sFileName); //履歴に同じファイルがあれば一番上にもっていくために削除しておく for i := Menu_OpenHistory.Items.Count -1 downto 0 do begin if (UpperCase(Menu_OpenHistory.Items[i].Hint) = ls_File) then begin Menu_OpenHistory.Items[i].Free; end; end; //空いている名前を取得する ls_Name := gfnsAvailableName(Copy(Menu_OpenHistory.Name, Length('MenuItem_') +1, MAXINT)); ls_Caption := gfnsFileNameGet(sFileName); //頭に挿入 Menu_OpenHistory.Items.Insert(0, NewItem( ls_Caption, //Caption 0, //ShortCut False, //Checked True, //Enabled MenuItem_OpenHistoryClick, //OnClickイベント 0, //HelpContext ls_Name //Name )); with Menu_OpenHistory.Items[0] do begin Hint := sFileName; OnAdvancedDrawItem := MenuItem_AdvancedDrawItem; OnMeasureItem := MenuItem_MeasureItem; end; if (Menu_OpenHistory.Items.Count > F_ciHISTORY) then begin //最後の履歴を削除 Menu_OpenHistory.Items[Menu_OpenHistory.Items.Count-1].Free; //NG mnuHistory.Items.Delete(mnuHistory.Items.Count-1); //Deleteではないことに注意 end; end; procedure TApp_TOOLBmpCaptureEx.Action_FileOpenExecute(Sender: TObject); //開く begin if not(Action_FileOpen.Visible) then begin Exit; end; if (gfnbKeyState(VK_SHIFT)) then begin //マイビデオフォルダ Dialog_Open.InitialDir := gfnsMyVideoPathGet; Dialog_Open.FileName := ''; end; if (Dialog_Open.Execute) then begin Dialog_Open.InitialDir := gfnsFilePathGet(Dialog_Open.FileName); FOpen(Dialog_Open.FileName); end; end; procedure TApp_TOOLBmpCaptureEx.FImageSave(sFileName : WideString); var lb_Ret : Boolean; li_Ret : Integer; ls_Ext : WideString; begin if (gfnbFileExists(sFileName)) then begin li_Ret := gfniMessageBoxYesNo(WideFormat('%s'#13'は既に存在します。上書きしますか?', [sFileName]), '名前を付けて保存'); if (li_Ret <> ID_YES) then begin Exit; end; end; Screen.Cursor := crHourGlass; try ls_Ext := WideLowerCase(gfnsFileExtGet(sFileName)); if (ls_Ext = gcsEXT_GIF) then begin //GIF if (Image_Bitmap.Picture.Bitmap.Transparent) then begin lb_Ret := gfnbGifSave(Image_Bitmap.Picture.Bitmap, sFileName, Image_Bitmap.Picture.Bitmap.TransparentColor); end else begin lb_Ret := gfnbGifSave(Image_Bitmap.Picture.Bitmap, sFileName); end; end else if gfnbIsIncludeList(ls_Ext, gcsEXT_JPEG) then begin //JPEG lb_Ret := gfnbJpegSave(Image_Bitmap.Picture.Bitmap, sFileName, 80); //品質は80で固定 {$IFDEF GDIPLUS} end else if (ls_Ext = gcsEXT_PNG) then begin //PNG lb_Ret := gfnbPngSave(Image_Bitmap.Picture.Bitmap, sFileName); end else if gfnbIsIncludeList(ls_Ext, gcsEXT_TIFF) then begin //TIFF lb_Ret := gfnbTiffSave(Image_Bitmap.Picture.Bitmap, sFileName); {$ENDIF} end else {if (ls_Ext = F_csEXT_BMP) then} begin //BMP lb_Ret := gfnbBmpSave(Image_Bitmap.Picture.Bitmap, sFileName); end; finally Screen.Cursor := crDefault; end; if not(lb_Ret) then begin gpcShowMessage(WideFormat('%s'#13'保存できませんでした', [sFileName])); end; end; procedure TApp_TOOLBmpCaptureEx.Action_FileSaveAsExecute(Sender: TObject); //保存 var ls_FileName : WideString; ls_Ext : WideString; begin if (Image_Bitmap.Picture.Bitmap.Width <= 0) or (Image_Bitmap.Picture.Bitmap.Height <= 0) then begin Exit; end; if (gfnbKeyState(VK_SHIFT)) then begin //マイピクチャフォルダ Dialog_SaveAs.InitialDir := gfnsMyPicturePathGet; Dialog_SaveAs.FileName := gfnsFileNameGet(Dialog_SaveAs.FileName); end; if (Dialog_SaveAs.Execute) then begin ls_FileName := Dialog_SaveAs.FileName; Dialog_SaveAs.InitialDir := gfnsFilePathGet(ls_FileName); case Dialog_SaveAs.FilterIndex of G_ciFILESAVE_BMP :begin //BMP ls_Ext := gcsEXT_BMP; end; G_ciFILESAVE_JPEG :begin //JPEG ls_Ext := gcsEXT_JPEG[0]; end; G_ciFILESAVE_GIF :begin //GIF ls_Ext := gcsEXT_GIF; end; G_ciFILESAVE_PNG :begin //PNG ls_Ext := gcsEXT_PNG; end; G_ciFILESAVE_TIFF :begin //TIFF ls_Ext := gcsEXT_TIFF[0]; end; else begin //「すべて」を選んだ場合のフォーマットはBMP ls_Ext := gcsEXT_BMP; end; end; if (WideLowerCase(gfnsFileExtGet(ls_FileName)) <> ls_Ext) then begin //選択ファイルの拡張子がls_Extと同じならそのまま。違えばls_Extを付け足す ls_FileName := ls_FileName + ls_Ext; end; FImageSave(ls_FileName); end; end; procedure TApp_TOOLBmpCaptureEx.Action_FileSaveBmpExecute(Sender: TObject); begin // if (Sender = Action_FileSaveGif) then begin Dialog_SaveAs.FilterIndex := G_ciFILESAVE_GIF; end else if (Sender = Action_FileSaveJpeg) then begin Dialog_SaveAs.FilterIndex := G_ciFILESAVE_JPEG; end else if (Sender = Action_FileSavePng) then begin Dialog_SaveAs.FilterIndex := G_ciFILESAVE_PNG; end else if (Sender = Action_FileSaveTiff) then begin Dialog_SaveAs.FilterIndex := G_ciFILESAVE_TIFF; end else begin //デフォルトはBMP Dialog_SaveAs.FilterIndex := G_ciFILESAVE_BMP; end; Action_FileSaveAsExecute(nil); end; procedure TApp_TOOLBmpCaptureEx.Action_PlayPlayPauseExecute(Sender: TObject); //再生/一時停止 begin if (Assigned(FGraphBuilder)) then begin if (gfnbKeyState(VK_SHIFT)) then begin //Shift併用でリプレイ Action_PlayReplayExecute(nil); end else if (gfnPlayStateGet(FGraphBuilder) = State_Running) then begin Action_PlayPauseExecute(nil); end else begin Action_PlayPlayExecute(nil); end; end else begin Action_FileOpenExecute(nil); end; end; procedure TApp_TOOLBmpCaptureEx.Action_PlayPlayExecute(Sender: TObject); //再生開始 const lci_THRESHOLD = 0.1; var l_MediaControl : IMediaControl; begin if not(Sender = Image_0) then begin FbPause := False; end; if (Assigned(FGraphBuilder)) then begin if (gfnbKeyState(VK_CONTROL)) then begin if (Abs(FfVideoTime - FfAudioTime) > 0.1) then begin //FMediaPosition.put_CurrentPosition(FfVideoTime); FSetMediaPosition(FfVideoTime); end; end; FGraphBuilder.QueryInterface(IMediaControl, l_MediaControl); l_MediaControl.Run; l_MediaControl := nil; Timer_Time.Enabled := True; // Action_PlayPlayPause.ImageIndex := Action_PlayPause.ImageIndex; end; end; procedure TApp_TOOLBmpCaptureEx.Action_PlayPauseExecute(Sender: TObject); //一時停止 var l_MediaControl : IMediaControl; begin // Timer_Time.Enabled := False; if (Assigned(FGraphBuilder)) then begin try FGraphBuilder.QueryInterface(IMediaControl, l_MediaControl); l_MediaControl.Pause; finally l_MediaControl := nil; end; Timer_TimeTimer(nil); if not(Sender = Image_0) then begin FbPause := True; end; end; // Action_PlayPlayPause.ImageIndex := Action_PlayPlay.ImageIndex; end; procedure TApp_TOOLBmpCaptureEx.Action_PlayStopExecute(Sender: TObject); //停止 var l_MediaControl : IMediaControl; begin FbPause := False; Timer_Time.Enabled := False; if (Assigned(FGraphBuilder)) then begin FGraphBuilder.QueryInterface(IMediaControl, l_MediaControl); l_MediaControl.Stop; //ただ停止させただけではPauseと変わらない //先頭に戻すにはIMediaPositionを使う FMediaPosition.put_CurrentPosition(0); //移動させただけでは現在位置のフレームが描画されない。 //現在位置のフレームを描画させるためにPauseあるいはStopWhenReadyを呼ぶ。 l_MediaControl.StopWhenReady; l_MediaControl := nil; TrackBar_Seek.Position := 0; // Action_PlayPlayPause.ImageIndex := Action_PlayPlay.ImageIndex; end; end; procedure TApp_TOOLBmpCaptureEx.Action_PlayReplayExecute(Sender: TObject); //リプレイ begin if (FMediaPosition = nil) then begin Exit; end; //FMediaPosition.put_CurrentPosition(0); FSetMediaPosition(0); Action_PlayPlayExecute(nil); end; procedure TApp_TOOLBmpCaptureEx.Action_PlayMuteExecute(Sender: TObject); //ミュート var l_BasicAudio : IBasicAudio; li_Volume : Integer; begin if (Action_PlayMute.Checked) then begin Action_PlayMute.ImageIndex := FiMuteImageIndex +1; li_Volume := -10000; end else begin Action_PlayMute.ImageIndex := FiMuteImageIndex; li_Volume := 0; end; if (Assigned(FGraphBuilder)) then begin { if (Action_PlayMute.Checked) then begin Action_PlayMute.ImageIndex := FiMuteImageIndex +1; li_Volume := -10000; end else begin Action_PlayMute.ImageIndex := FiMuteImageIndex; li_Volume := 0; end; } if (Succeeded(FGraphBuilder.QueryInterface(IBasicAudio, l_BasicAudio))) then begin try l_BasicAudio.put_Volume(li_Volume); finally l_BasicAudio := nil; end; end; end; end; procedure TApp_TOOLBmpCaptureEx.Action_PlaySkipBackExecute(Sender: TObject); //スキップ var lf_Shift : TRefTime; lf_Pos : TRefTime; begin if not(Assigned(FMediaPosition)) then begin Exit; end; if (FbThrough) then begin Exit; end; FbThrough := True; try if (Sender = Action_PlayHome) then begin //先頭へ lf_Pos := 0; end else if (Sender = Action_PlayEnd) then begin //末尾へ lf_Pos := FfDuration; end else begin //30秒スキップ if (Sender = Action_PlaySkipBack) or (Sender = Action_PlaySkip1minBack) then begin lf_Shift := -1; end else if (Sender = Action_PlaySkipNext) or (Sender = Action_PlaySkip1minNext) then begin lf_Shift := +1; end else begin Exit; end; if (Sender = Action_PlaySkipBack) or (Sender = Action_PlaySkipNext) then begin if (gfnbKeyState(VK_SHIFT)) then begin //Shift併用で10秒スキップ lf_Shift := lf_Shift * 10; end else begin //デフォルトは30秒スキップ lf_Shift := lf_Shift * 30; end; end else if (Sender = Action_PlaySkip1minBack) or (Sender = Action_PlaySkip1minNext) then begin //一時停止させる。 Action_PlayPauseExecute(nil); if (gfnbKeyState(VK_SHIFT)) then begin //Shift併用で0.5秒スキップ lf_Shift := lf_Shift * 0.5; end else begin //デフォルトは1秒スキップ lf_Shift := lf_Shift * 1; end; end; lf_Pos := FfVideoTime + lf_Shift; end; //範囲外だと位置の調整は行われないので範囲内に収める。 //FMediaPosition.put_CurrentPosition(FGetStepLimit(lf_Pos)); FSetMediaPosition(lf_Pos); finally Application.ProcessMessages; FbThrough := False; end; end; function TApp_TOOLBmpCaptureEx.FGetStepLimit(fPos : TRefTime) : TRefTime; begin //末尾に関しては長さをそのまま指定してもNG。フレーム一つ分引いておく。 Result := gfnfNumLimit(fPos, 0, FfDuration - (FfAvgTimePerFrame * 1)); end; function TApp_TOOLBmpCaptureEx.FIsStepEnd : Boolean; //終わりから5フレームに達しているか begin //終わりのフレームの前5フレームはキャプチャの時に終わりのフレームの5フレーム前 //に移動しないとキャプチャが完了できないのでその判定用 Result := (FfVideoTime >= FfDuration - (FfAvgTimePerFrame * FiBuffCount)); end; procedure TApp_TOOLBmpCaptureEx.FStep(iStep: Integer); //フレーム移動 var l_VideoFrameStep : IVideoFrameStep; begin if (FMediaPosition = nil) then begin Exit; end; try FfStepTime := 0; if (iStep > 0) then begin //現在より後のフレーム try FGraphBuilder.QueryInterface(IVideoFrameStep, l_VideoFrameStep); if (l_VideoFrameStep <> nil) and (l_VideoFrameStep.CanStep(iStep, nil) = S_OK) then begin if (l_VideoFrameStep.Step(iStep, nil) = S_OK) then begin //ステップが成功ならここで処理を抜ける Exit; end; end; finally l_VideoFrameStep := nil; end; //FMediaPosition.put_CurrentPosition(FGetStepTime(iStep)); FSetMediaPosition(FGetStepTime(iStep)); end; finally Timer_TimeTimer(nil); end; end; function TApp_TOOLBmpCaptureEx.FGetStepTime(iStep: Integer): TRefTime; begin //現在位置より前のフレーム //あるいはl_VideoFrameStep.Stepが失敗した場合 Result := FfVideoTime + (iStep * FfAvgTimePerFrame); //単純にF_fAvgTimePerFrame分を足し引きするだけだとフレームが動かない場合があるので0.5をかけた値を足す（あるいは引く） if (iStep <= 0) then begin Result := Result - (FfAvgTimePerFrame * 0.5); end else begin Result := Result + (FfAvgTimePerFrame * 0.5); end; //範囲内に収めないと調整されない。 Result := FGetStepLimit(Result); end; procedure TApp_TOOLBmpCaptureEx.FCaptureStep(fPosition : TRefTime; iStep : Integer); var lf_Pos : TRefTime; begin FfStepTime := fPosition + (iStep * FfAvgTimePerFrame); if (iStep <= 0) then begin lf_Pos := FfStepTime - FfAvgTimePerFrame * 0.6; end else begin lf_Pos := FfStepTime + FfAvgTimePerFrame * 0.4; end; Action_PlayPauseExecute(nil); FSetMediaPosition(lf_Pos); // FMediaPosition.put_CurrentPosition(FGetStepLimit(lf_Pos)); end; procedure TApp_TOOLBmpCaptureEx.Action_PlayFrameBackExecute(Sender: TObject); //フレーム移動 var li_Step : Integer; begin if not(Assigned(FMediaPosition)) then begin Exit; end; if (FbThrough) then begin Exit; end; FbThrough := True; try Action_PlayPauseExecute(nil); if (Sender = Action_PlayFrameBack) then begin li_Step := -1; end else if (Sender = Action_PlayFrameNext) then begin li_Step := +1; end else begin li_Step := 0; end; if (gfnbKeyState(VK_SHIFT)) then begin li_Step := li_Step * FiBuffCount; end; FStep(li_Step); finally Application.ProcessMessages; FbThrough := False; end; end; procedure TApp_TOOLBmpCaptureEx.Image_0DblClick(Sender: TObject); var lf_Pos : TRefTime; begin if (FMediaPosition = nil) or (Image_Bitmap.Picture.Bitmap.Width <= 0) or (Image_Bitmap.Picture.Bitmap.Height <= 0) then begin Exit; end; if (Sender is TImage) then begin if (gfnbKeyState(VK_SHIFT)) then begin //Shiftキー併用でダブルクリックしたフレームから5フレーム前をキャプチャ //つまりダブルクリックしたフレームが5フレーム目になるようにキャプチャする。 FfStepTime := FGetCapturedTime(TImage(Sender)) - (FfAvgTimePerFrame * FiBuffCount); end else begin FfStepTime := FGetCapturedTime(TImage(Sender)); end; lf_Pos := FfStepTime - (FfAvgTimePerFrame); //範囲内に収めないと調整されない。 //FMediaPosition.put_CurrentPosition(FGetStepLimit(lf_Pos)); FSetMediaPosition(lf_Pos); Action_CaptureExecute(nil); end; end; procedure TApp_TOOLBmpCaptureEx.FSetMediaPosition(fPos : TRefTime); var lb_Playing : Boolean; l_MediaControl : IMediaControl; l_State : TFilterState; begin if (FbSampleGrabber) then begin FSampleGrabber.SetBufferSamples(False); end; lb_Playing := False; if (Assigned(FGraphBuilder)) then begin FGraphBuilder.QueryInterface(IMediaControl, l_MediaControl); try if (l_MediaControl.GetState(100, l_State) = S_OK) then begin lb_Playing := (l_State = State_Running); end; finally l_MediaControl := nil; end; end; if (lb_Playing) then begin Action_PlayPauseExecute(nil); end; FMediaPosition.put_CurrentPosition(FGetStepLimit(fPos)); if (FbSampleGrabber) then begin FSampleGrabber.SetBufferSamples(True); end; if (lb_Playing) then begin Action_PlayPlayExecute(nil); end; end; function TApp_TOOLBmpCaptureEx.FGetCapturedTime(AImage : TImage) : TRefTime; var li_Index : Integer; begin li_Index := gfniRightVal(AImage.Name); Result := FBitmap[li_Index].Time; end; function TApp_TOOLBmpCaptureEx.FGetFrameIndex: Integer; var i : Integer; l_Panel : TPanel; begin for i := 0 to High(FBitmap) do begin l_Panel := gfnFindControl(Panel_Frame, Format('Panel_%d', [i])) as TPanel; if (l_Panel <> nil) then begin if (Screen.ActiveControl = l_Panel) then begin FiFrameIndex := i; Break; end; end; end; // Result := gfniNumLimit(FiFrameIndex, 0, High(FBitmap)); Result := FiFrameIndex; end; procedure TApp_TOOLBmpCaptureEx.Action_CaptureBackExecute(Sender: TObject); var lf_Time : TRefTime; l_Label : TLabel; i : Integer; begin if (FMediaPosition = nil) or (Image_Bitmap.Picture.Bitmap.Width <= 0) or (Image_Bitmap.Picture.Bitmap.Height <= 0) then begin Exit; end; if (Sender = Action_CaptureBack) then begin if (gfnbKeyState(VK_SHIFT)) then begin //10フレーム前から FCaptureStep(FGetCapturedTime(Image_0), -(FiBuffCount +1) * 2); end else begin //5フレーム前から //今ビデオで表示されているフレームの10フレーム前から5フレームを取得する FCaptureStep(FGetCapturedTime(Image_0), -(FiBuffCount +1)); end; end else if (Sender = Action_CaptureNext) then begin if (FfVideoTime > FfDuration - (FfAvgTimePerFrame * FiBuffCount)) then begin //最後の5フレーム FCaptureStep(FfDuration, -FiBuffCount); end else begin lf_Time := 0.000; for i := High(FBitmap) downto 0 do begin if (FbSampleGrabber) then begin lf_Time := FBitmap[i].Time; end else begin l_Label := FGetLabel(i); if (l_Label = nil) then begin Continue; end; lf_Time := gfniStrToInt(l_Label.Caption); end; if (lf_Time > 0.000) then begin Break; end; end; if (gfnbKeyState(VK_SHIFT)) then begin //10フレーム後まで FCaptureStep(lf_Time, FiBuffCount + 2); end else begin FCaptureStep(lf_Time, 1); end; end; end else begin if (gfnPlayStateGet(FGraphBuilder) <> State_Running) then begin //一時停止中 FStep(0); end else if (FIsStepEnd) then begin //終わりの5フレーム FCaptureStep(FfDuration, -FiBuffCount); end; end; Action_CaptureExecute(nil); end; procedure TApp_TOOLBmpCaptureEx.Action_CaptureExecute(Sender: TObject); //ビデオ映像からビットマップを取得。 begin if (FMediaPosition = nil) or (Image_Bitmap.Picture.Bitmap.Width <= 0) or (Image_Bitmap.Picture.Bitmap.Height <= 0) then begin Exit; end; Action_CaptureNow.Enabled := False; Action_CaptureBack.Enabled := Action_CaptureNow.Enabled; Action_CaptureNext.Enabled := Action_CaptureNow.Enabled; Action_PlayPlayPause.Enabled := Action_CaptureNow.Enabled; Action_PlayReplay.Enabled := Action_CaptureNow.Enabled; Action_PlayHome.Enabled := Action_CaptureNow.Enabled; Action_PlayEnd.Enabled := Action_CaptureNow.Enabled; Action_PlaySkipBack.Enabled := Action_CaptureNow.Enabled; Action_PlaySkipNext.Enabled := Action_CaptureNow.Enabled; Action_PlaySkip1minBack.Enabled := Action_CaptureNow.Enabled; Action_PlaySkip1minNext.Enabled := Action_CaptureNow.Enabled; Action_PlayFrameBack.Enabled := Action_CaptureNow.Enabled; Action_PlayFrameNext.Enabled := Action_CaptureNow.Enabled; Panel_Frame.Enabled := Action_CaptureNow.Enabled; TrackBar_Seek.Enabled := Action_CaptureNow.Enabled; FbCapture := True; FiImageIndex := 0; if (FbSampleGrabber) then begin if (FbPause) then begin Action_PlayPlayExecute(Image_0); //Image_0を引数に渡すことでF_bPauseをFalseにしない end; end else begin //サンプルグラバーのコールバックが機能しない場合 //タイマーを使って再生中のメディアのビットマップを取得 Timer_Capture.Enabled := True; // Action_PlayPlayExecute(Image_0); //Image_0を引数に渡すことでF_bPauseをFalseにしない if (FbPause) then begin //Image_0を引数に渡すことでF_bPauseをFalseにしない Action_PlayPlayExecute(Image_0); end else begin Action_PlayPlayExecute(nil); end; end; end; procedure TApp_TOOLBmpCaptureEx.TrackBar_SeekMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); begin if (Action_CaptureSampleGrabber.Checked) and (FbSampleGrabber) and (Button = mbLeft) then begin FSampleGrabber.SetBufferSamples(False); end; end; procedure TApp_TOOLBmpCaptureEx.TrackBar_SeekMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer); var li_Width, li_Center, li_Start, li_End: Integer; li_Pos: Integer; lrc_Rect: TRect; begin if (TrackBar_Seek.Max > TrackBar_Seek.Min) then begin if (gfnbKeyState(VK_LBUTTON)) then begin li_Pos := TrackBar_Seek.Position; TrackBar_Seek.Hint := Format('%s秒', [gfnsSecToTimeStr(li_Pos / F_ciTRACKPOS, 1)]); end else begin lrc_Rect := TrackBar_Seek.SeekRect; if (X < lrc_Rect.Left) then begin TrackBar_Seek.Hint := Action_PlaySkipBack.Hint; end else if (X > lrc_Rect.Right) then begin TrackBar_Seek.Hint := Action_PlaySkipNext.Hint; end else begin li_Center := gfniRoundUp(gfniRectWidth(TrackBar_Seek.ThumbRect) / 2); //スライダーボタンの幅の中心 li_Width := TrackBar_Seek.SeekWidth; //スライダーのスライドする正味のボックスの幅 li_Start := TrackBar_Seek.SeekRect.Left + li_Center; if (X >= li_Start) then begin li_End := lrc_Rect.Right - li_Center; if (X <= li_End) then begin li_Pos := Trunc((X - li_Start) / (li_Width - li_Center * 2) * (TrackBar_Seek.Max - TrackBar_Seek.Min)); end else begin li_Pos := TrackBar_Seek.Max; end; end else begin li_Pos := TrackBar_Seek.Min; end; TrackBar_Seek.Hint := Format('%s秒', [gfnsSecToTimeStr(li_Pos / F_ciTRACKPOS, 1)]); end; end; Application.ActivateHint(gfnptMousePosGet); end else begin TrackBar_Seek.Hint := ''; end; end; procedure TApp_TOOLBmpCaptureEx.TrackBar_SeekMouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); var li_Width : Integer; li_Center : Integer; li_Start : Integer; li_End : Integer; li_Pos : Integer; lf_Pos : Extended; lrc_Rect : TRect; lb_Timer : Boolean; begin if (Button = mbLeft) then begin if (Action_CaptureSampleGrabber.Checked) and (FbSampleGrabber) then begin FSampleGrabber.SetBufferSamples(True); end; //ダイアログで選択した後偶然トラックバーの上にマウスが乗ったままだとクリック //していないのにクリックしたようになってしまうことへの対処。 if not(TrackBar_Seek.Touched) then begin Exit; end; lb_Timer := Timer_Time.Enabled; Timer_Time.Enabled := False; lrc_Rect := TrackBar_Seek.SeekRect; //スライダのRect if (TrackBar_Seek.ThumbHold) then begin //つまみを掴んで移動した FMediaPosition.put_CurrentPosition(TrackBar_Seek.Position / F_ciTRACKPOS); end else begin if (X < lrc_Rect.Left) then begin //トラックバーの左端をクリックした Action_PlaySkipBackExecute(Action_PlaySkipBack); end else if (X > lrc_Rect.Right) then begin //トラックバーの右端をクリックした Action_PlaySkipBackExecute(Action_PlaySkipNext); end else begin //トラックバーのつまみのない場所をクリックした li_Center := gfniRoundUp(gfniRectWidth(TrackBar_Seek.ThumbRect) / 2); //スライダーボタンの幅の中心 li_Width := TrackBar_Seek.SeekWidth; //スライダーのスライドする正味のボックスの幅 li_Start := lrc_Rect.Left + li_Center; if (X >= li_Start) then begin li_End := lrc_Rect.Right - li_Center; if (X <= li_End) then begin lf_Pos := (X - li_Start) / (li_Width - li_Center * 2) * (TrackBar_Seek.Max - TrackBar_Seek.Min) / F_ciTRACKPOS; li_Pos := Trunc(lf_Pos); end else begin li_Pos := TrackBar_Seek.Max; lf_Pos := li_Pos; end; end else begin li_Pos := TrackBar_Seek.Min; lf_Pos := li_Pos; end; TrackBar_Seek.Position := li_Pos * F_ciTRACKPOS; FMediaPosition.put_CurrentPosition(lf_Pos); Timer_TimeTimer(nil); Timer_Time.Enabled := lb_Timer; end; end; end; end; //--- フレームレート --- function TApp_TOOLBmpCaptureEx.FGetFrameRate : String; var l_EnumPins : IEnumPins; l_Pin : IPin; l_PinInfo : TPinInfo; l_MediaType : TAMMediaType; li_Time : Int64; begin Result := '-'; FfAvgTimePerFrame := 0; if (Image_Bitmap.Picture.Bitmap.Width <= 0) or (Image_Bitmap.Picture.Bitmap.Height <= 0) then begin Exit; end; //フレーム間の時間が0だと色々困るので29.97fpsであるものとみなす。 Result := '29.97'; FfAvgTimePerFrame := 1 / 29.97; l_EnumPins := nil; if (FVideoRenderer <> nil) then begin FVideoRenderer.EnumPins(l_EnumPins); end; if (l_EnumPins <> nil) then begin while(l_EnumPins.Next(1, l_Pin, nil) = S_OK) do begin l_Pin.QueryPinInfo(l_PinInfo); try if (l_PinInfo.dir = PINDIR_INPUT) then begin //入力 l_Pin.ConnectionMediaType(l_MediaType); try if (IsEqualGUID(l_MediaType.majortype, MEDIATYPE_Video)) then begin if (l_MediaType.pbFormat <> nil) then begin if (IsEqualGUID(l_MediaType.formattype, FORMAT_VideoInfo)) then begin //VIDEOINFOHEADER li_Time := PVideoInfoHeader(l_MediaType.pbFormat)^.AvgTimePerFrame; end else if (IsEqualGUID(l_MediaType.formattype, FORMAT_VideoInfo2)) then begin //VIDEOINFOHEADER2 li_Time := PVideoInfoHeader2(l_MediaType.pbFormat)^.AvgTimePerFrame; end else if (IsEqualGUID(l_MediaType.formattype, FORMAT_MPEGVideo)) then begin //MPEG1VIDEOINFO li_Time := PMpeg1VideoInfo(l_MediaType.pbFormat)^.hdr.AvgTimePerFrame; end else if (IsEqualGUID(l_MediaType.formattype, FORMAT_MPEG2Video)) then begin //MPEG2VIDEOINFO li_Time := PMpeg2VideoInfo(l_MediaType.pbFormat)^.hdr.AvgTimePerFrame; end else begin li_Time := 0; end; if (li_Time > 0) then begin FfAvgTimePerFrame := li_Time / UNITS; Result := Format('%g', [gfniRound(100 / FfAvgTimePerFrame) / 100]); Break; end; end; end; finally FreeMediaType(@l_MediaType); end; end; finally if (l_PinInfo.pFilter <> nil) then begin l_PinInfo.pFilter := nil; end; l_Pin := nil; end; end; l_EnumPins := nil; end; end; //-------- //--- 再生速度変更 --- procedure TApp_TOOLBmpCaptureEx.Action_PlayRate_10Execute(Sender: TObject); //wmv,wmaとamazonのmp3は再生速度の変更はできない var lf_Rate : Double; i : Integer; begin if (Sender is TAction) then begin TAction(Sender).Checked := True; end; if (FMediaPosition = nil) then begin Exit; end; lf_Rate := 1.0; for i := 0 to MenuItem_Rate.Count -1 do begin if (MenuItem_Rate.Items[i].Checked) then begin lf_Rate := StrToFloatDef(MenuItem_Rate.Items[i].Caption, 1.0); Break; end; end; FMediaPosition.put_Rate(lf_Rate); end; //-------- procedure TApp_TOOLBmpCaptureEx.actNop(Sender: TObject); begin // end; procedure TApp_TOOLBmpCaptureEx.FSetPanelColor(APanel : TPanel); var l_Panel : TPanel; i : Integer; begin for i := 0 to FiBuffCount -1 do begin l_Panel := gfnFindControl(Panel_Frame, Format('Panel_%d', [i])) as TPanel; if (l_Panel <> nil) then begin if (l_Panel = APanel) and (FMediaPosition <> nil) then begin l_Panel.Color := clBtnShadow; end else begin l_Panel.Color := clBtnFace; end; end; end; end; procedure TApp_TOOLBmpCaptureEx.Image_0Click(Sender: TObject); var l_Panel : TPanel; l_Image : TImage; li_Num : Integer; begin if (FMediaPosition = nil) or (Image_Bitmap.Picture.Bitmap.Width <= 0) or (Image_Bitmap.Picture.Bitmap.Height <= 0) then begin Exit; end; if (Sender is TPanel) or (Sender is TImage) or (Sender is TLabel) then begin li_Num := gfniRightVal(TComponent(Sender).Name); l_Panel := gfnFindControl(Panel_Frame, Format('Panel_%d', [li_Num])) as TPanel; l_Image := gfnFindControl(Panel_Frame, Format('Image_%d', [li_Num])) as TImage; //AIU if (l_Panel = nil) or (l_Image = nil) then begin Exit; end; FiFrameIndex := li_Num; FSetPanelColor(l_Panel); Image_Bitmap.Picture.Bitmap.Assign(l_Image.Picture.Bitmap); Image_Bitmap.Refresh; Action_EditCopyExecute(nil); end; end; procedure TApp_TOOLBmpCaptureEx.Action_HelpVersionInfoExecute(Sender: TObject); //バージョン情報 begin gpcVersionInfoCreate; gpcVersionInfoURLSet('http://drang.s4.xrea.com/program/tool/tool/vcapt/help/'); gpcVersionInfoShowModal; gpcVersionInfoRelease; end; procedure TApp_TOOLBmpCaptureEx.Action_Zoom100Execute(Sender: TObject); begin if not(Action_Zoom100.Enabled) then begin Exit; end; Action_ZoomAlwaysFit.Checked := False; gpcImage_Zoom100(Image_Bitmap); FSetStretchCaption; end; procedure TApp_TOOLBmpCaptureEx.Action_ZoomAlwaysFitExecute(Sender: TObject); begin Action_ZoomAlwaysFit.Checked := True; ToolButton_ZoomFit.Down := True; Image_Bitmap.Align := alClient; FSetStretchCaption; end; procedure TApp_TOOLBmpCaptureEx.Image_BitmapDblClick(Sender: TObject); begin if (Image_Bitmap.Align = alClient) then begin Action_Zoom100Execute(nil); end else begin Action_ZoomAlwaysFitExecute(nil); end; end; procedure TApp_TOOLBmpCaptureEx.Action_ZoomUpExecute(Sender: TObject); //拡大 begin if not(Action_ZoomUp.Enabled) then begin Exit; end; Action_ZoomAlwaysFit.Checked := False; Image_Bitmap.Align := alNone; gpcImage_Zoom(Image_Bitmap, +1); FSetStretchCaption; end; procedure TApp_TOOLBmpCaptureEx.Action_ZoomDownExecute(Sender: TObject); //縮小 begin if not(Action_ZoomDown.Enabled) then begin Exit; end; Action_ZoomAlwaysFit.Checked := False; Image_Bitmap.Align := alNone; gpcImage_Zoom(Image_Bitmap, -1); FSetStretchCaption; end; procedure TApp_TOOLBmpCaptureEx.Grid_BitmapMouseWheelDown(Sender: TObject; Shift: TShiftState; MousePos: TPoint; var Handled: Boolean); //縮小 begin Action_ZoomDownExecute(nil); end; procedure TApp_TOOLBmpCaptureEx.Grid_BitmapMouseWheelUp(Sender: TObject; Shift: TShiftState; MousePos: TPoint; var Handled: Boolean); //拡大 begin Action_ZoomUpExecute(nil); end; procedure TApp_TOOLBmpCaptureEx.Image_BitmapMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); begin if (Grid_Bitmap.CanFocus) then begin Grid_Bitmap.SetFocus; end; if (Button = mbLeft) // and (Image_Bitmap.Align <> alClient) then begin gpcImage_MoveStart(X, Y); end; end; procedure TApp_TOOLBmpCaptureEx.Image_BitmapMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer); begin gfnbImage_Move(Image_Bitmap, X, Y); end; procedure TApp_TOOLBmpCaptureEx.Image_BitmapMouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); begin gpcImage_MoveDone(Image_Bitmap, X, Y); end; //------------------------------------------------------------------------------ //IniFile const lcsSECT_BOUNDS = 'CAPTURE_Bounds'; lcsSECT_FILE = 'CAPTURE_File'; lcsKEY_GIFTRANSPARENT = 'GIFTransparent'; lcsSECT_PLAY = 'CAPTURE_Play'; lcsKEY_PLAYMUTE = 'Mute'; lcsSECT_DIALOG = 'CAPTURE_Dialog'; lcsKEY_DLGOPENPATH = 'OpenPath'; lcsKEY_DLGSAVEPATH = 'SavePath'; lcsKEY_DLGOPENINDEX = 'OpenFilterIndex'; lcsKEY_DLGSAVEINDEX = 'SaveFilterIndex'; lcsKEY_DLGWALLPATH = 'WallpaperPath'; lcsKEY_DLGPRGRAMPATH = 'SelProgramPath'; lcsSECT_OPT = 'CAPTURE_Option'; lcsKEY_DISPTIMEVERBOSE = 'TimeVerbose'; lcsKEY_DISPTOOLBAR = 'ToolBar'; lcsKEY_DISPSTATUSBAR = 'StatusBar'; lcsKEY_DISPHINTPOPUP = 'HintPopup'; lcsKEY_CAPTURESAMPLEGRABBER = 'SampleGrabber'; lcsSECT_OPENHISTORY = 'CAPTURE_OpenHistory'; lcsSECT_SAVEHISTORY = 'CAPTURE_SaveHistory'; lcsSECT_PROGRAM = 'CAPTURE_Program'; lcsKEY_FOREGROUND = 'Foreground'; lcsSECT_PROGRAMLIST = 'CAPTURE_ProgramList'; //IniFile procedure TApp_TOOLBmpCaptureEx.LoadIni(AIniFile: TMyIniFile); procedure _ReadHistory(AIniFile : TMyIniFile; sSection : WideString; APopupMenu : TPopupMenu); var l_History : TMyWStrings; i : Integer; begin if (AIniFile.SectionExists(sSection)) then begin l_History := TMyWStrings.Create; try AIniFile.ReadSectionText(sSection, l_History); for i := l_History.Count-1 downto 0 do begin FAddOpenHistory(l_History[i]); end; finally l_History.Free; end; end; end; const lci_MINWIDTH = 32; lci_MINHEIGHT = 32; var i : Integer; begin with AIniFile do begin if (gfnbKeyState(VK_SHIFT)) then begin //[Shift]併用でメインモニターで起動 // Self.SetBounds(75, 75, Self.Width, Self.Height); end else begin SetMonitorBoundsRect(lcsSECT_BOUNDS, Self); end; //[File] // Action_FileGifTransparent.Checked := ReadBool(lcsSECT_FILE, lcsKEY_GIFTRANSPARENT, Action_File_GifTransparent.Checked); //[Play] Action_PlayMute.Checked := ReadBool(lcsSECT_PLAY, lcsKEY_PLAYMUTE, Action_PlayMute.Checked); //[Program] Action_ProgramForeground.Checked := ReadBool(lcsSECT_PROGRAM, lcsKEY_FOREGROUND, Action_ProgramForeground.Checked); //[ProgramList] ReadSectionText(lcsSECT_PROGRAMLIST, ComboBox_Program.Items); for i := 0 to ComboBox_Program.Items.Count-1 do begin gpcProgramIconAdd(ImageList_Program, ComboBox_Program.Items[i]); end; FCreateProgramMenu; //[Dialog] Dialog_Open.InitialDir := ReadString (lcsSECT_DIALOG, lcsKEY_DLGOPENPATH, Dialog_Open.InitialDir); Dialog_SaveAs.InitialDir := ReadString (lcsSECT_DIALOG, lcsKEY_DLGSAVEPATH, Dialog_SaveAs.InitialDir); Dialog_Program.InitialDir := ReadString (lcsSECT_DIALOG, lcsKEY_DLGPRGRAMPATH, Dialog_Program.InitialDir); // F_sWallpaperIniDir := ReadString (lcsSECT_DIALOG, lcsKEY_DLGWALLPATH, F_sWallpaperIniDir); Dialog_Open.FilterIndex := ReadInteger(lcsSECT_DIALOG, lcsKEY_DLGOPENINDEX, Dialog_Open.FilterIndex); Dialog_SaveAs.FilterIndex := ReadInteger(lcsSECT_DIALOG, lcsKEY_DLGSAVEINDEX, Dialog_SaveAs.FilterIndex); //[Option] Action_ShowTimeVerbose.Checked := ReadBool(lcsSECT_OPT, lcsKEY_DISPTIMEVERBOSE, Action_ShowTimeVerbose.Checked); Action_ShowToolBar.Checked := ReadBool(lcsSECT_OPT, lcsKEY_DISPTOOLBAR, Action_ShowToolBar.Checked); Action_ShowStatusBar.Checked := ReadBool(lcsSECT_OPT, lcsKEY_DISPSTATUSBAR, Action_ShowStatusBar.Checked); Action_ShowHintPopup.Checked := ReadBool(lcsSECT_OPT, lcsKEY_DISPHINTPOPUP, Action_ShowHintPopup.Checked); Action_ShowToolBarExecute(nil); Action_ShowStatusBarExecute(nil); Action_ShowHintPopupExecute(nil); Action_CaptureSampleGrabber.Checked := ReadBool(lcsSECT_OPT, lcsKEY_CAPTURESAMPLEGRABBER, Action_CaptureSampleGrabber.Checked); _ReadHistory(AIniFile, lcsSECT_OPENHISTORY, Menu_OpenHistory); end; end; function TApp_TOOLBmpCaptureEx.LoadIni: Boolean; var l_IniFile : TMyIniFile; begin Result := False; //Shift+Ctrl起動で設定を読み込まない。 if (gfnbKeyStateAnd([VK_SHIFT, VK_CONTROL])) then begin Exit; end; l_IniFile := TMyIniFile.Create; try LoadIni(l_IniFile); finally l_IniFile.Free; end; Result := True; end; //設定保存 procedure TApp_TOOLBmpCaptureEx.SaveIni(AIniFile: TMyIniFile); procedure _WriteHistory(AIniFile : TMyIniFile; sSection : WideString; APopupMenu : TPopupMenu); var l_History : TMyWStrings; i : Integer; begin l_History := TMyWStrings.Create; try for i := 0 to APopupMenu.Items.Count-1 do begin l_History.Add(APopupMenu.Items[i].Hint); end; AIniFile.WriteSectionText(sSection, l_History); finally l_History.Free; end; end; begin with AIniFile do begin if not(gfnbKeyState(VK_SHIFT)) then begin WriteBoundsRect(lcsSECT_BOUNDS, Self); end; //[File] // WriteBool(lcsSECT_FILE, lcsKEY_GIFTRANSPARENT, Action_File_GifTransparent.Checked); //[Play] WriteBool(lcsSECT_PLAY, lcsKEY_PLAYMUTE, Action_PlayMute.Checked); //[Program] WriteBool(lcsSECT_PROGRAM, lcsKEY_FOREGROUND, Action_ProgramForeground.Checked); //[ProgramList] WriteSectionText(lcsSECT_PROGRAMLIST, ComboBox_Program.Items); //[Dialog] WriteString (lcsSECT_DIALOG, lcsKEY_DLGOPENPATH, Dialog_Open.InitialDir); WriteString (lcsSECT_DIALOG, lcsKEY_DLGSAVEPATH, Dialog_SaveAs.InitialDir); WriteString (lcsSECT_DIALOG, lcsKEY_DLGPRGRAMPATH, Dialog_Program.InitialDir); // WriteString (lcsSECT_DIALOG, lcsKEY_DLGWALLPATH, F_sWallpaperIniDir); WriteInteger(lcsSECT_DIALOG, lcsKEY_DLGOPENINDEX, Dialog_Open.FilterIndex); WriteInteger(lcsSECT_DIALOG, lcsKEY_DLGSAVEINDEX, Dialog_SaveAs.FilterIndex); //[Option] WriteBool(lcsSECT_OPT, lcsKEY_DISPTIMEVERBOSE, Action_ShowTimeVerbose.Checked); WriteBool(lcsSECT_OPT, lcsKEY_DISPTOOLBAR, Action_ShowToolBar.Checked); WriteBool(lcsSECT_OPT, lcsKEY_DISPSTATUSBAR, Action_ShowStatusBar.Checked); WriteBool(lcsSECT_OPT, lcsKEY_DISPHINTPOPUP, Action_ShowHintPopup.Checked); WriteBool(lcsSECT_OPT, lcsKEY_CAPTURESAMPLEGRABBER, Action_CaptureSampleGrabber.Checked); _WriteHistory(AIniFile, lcsSECT_OPENHISTORY, Menu_OpenHistory); // _WriteHistory(l_IniFile, lcsSECT_SAVEHISTORY, Menu_SaveHistory); end; end; procedure TApp_TOOLBmpCaptureEx.SaveIni; var l_IniFile : TMyIniFile; begin //Shift+Ctrl起動で設定を書き込まない。 if (gfnbKeyState(VK_SHIFT) and gfnbKeyState(VK_CONTROL)) then begin Exit; end; l_IniFile := TMyIniFile.Create; try SaveIni(l_IniFile); try l_IniFile.UpdateFile; except end; finally l_IniFile.Free; end; end; //------------------------------------------------------------------------------ //プログラムリスト { procedure TApp_TOOLBmpCaptureEx.ComboBox_ProgramDrawItem(Control: TWinControl; Index: Integer; Rect: TRect; State: TOwnerDrawState); const lci_MARGIN = 2; var l_Rect : TRect; li_Width : Integer; li_Height : Integer; ls_File : WideString; ls_Name : WideString; l_Bitmap : TBitmap; begin l_Rect := Rect; li_Height := gfniRectHeight(Rect); li_Width := li_Height; with ComboBox_Program.Canvas do begin FillRect(l_Rect); l_Bitmap := TBitmap.Create; try l_Bitmap.Width := ImageList_Program.Width; l_Bitmap.Height := ImageList_Program.Height; ImageList_Program.GetBitmap(Index, l_Bitmap); BitBlt(Handle, Rect.Left + (li_Width - l_Bitmap.Width) div 2, Rect.Top + (li_Height - l_Bitmap.Height) div 2, l_Bitmap.Width, l_Bitmap.Height, l_Bitmap.Canvas.Handle, 0, 0, SRCCOPY); finally l_Bitmap.Free; end; Inc(l_Rect.Left, li_Width + lci_MARGIN); //DrawTextWに渡す文字列に処理に時間がかかる関数を渡すと挙動がおかしくなるので予め処理しておく。 ls_File := gfnsAnsiToWideEx(ComboBox_Program.Items[Index]); ls_Name := gfnsFileNameGet(ls_File); // if not(gfnbFileExists(ls_File)) then begin // Font.Style := Font.Style + [fsStrikeOut]; // end; DrawTextW(Handle, PWideChar(ls_Name), -1, l_Rect, DT_NOPREFIX or DT_VCENTER or DT_SINGLELINE); end; end; } var lsProgramFile : WideString; lbProgramDone : Boolean; lhTargetHandle : HWND; lbIsIconic : Boolean; function ForegroundEnumWindowProc(hHandle: HWND; iLParam: LPARAM): BOOL; stdcall; begin Result := True; if (WideUpperCase(gfnsExeNameGet(hHandle)) = lsProgramFile) then begin //実行ファイルの名前が同じだった。 lhTargetHandle := hHandle; if (IsIconic(hHandle)) then begin lbIsIconic := True; Result := False; end; end; end; procedure TApp_TOOLBmpCaptureEx.Action_ProgramRunExecute(Sender: TObject); var ls_Exe : WideString; begin // if (Sender is TMenuItem) then begin //「ファイル」→「プログラム」→「実行」のサブメニューから呼ばれた。 ls_Exe := TMenuItem(Sender).Hint; end else begin //プログラムリストから選択。 if (ComboBox_Program.ItemIndex < 0) then begin Exit; end; ls_Exe := ComboBox_Program.Items[ComboBox_Program.ItemIndex]; end; if not(gfnbFileExists(ls_Exe)) then begin Exit; end; lbProgramDone := False; if (Action_ProgramForeground.Checked) then begin //既に実行済みなら新規に実行はせず前面に移動させるだけ if (gfnbIsShortCut(ls_Exe)) then begin lsProgramFile := gfnsLinkToFile(ls_Exe); end else begin lsProgramFile := ls_Exe; end; lsProgramFile := WideUpperCase(lsProgramFile); lhTargetHandle := 0; lbIsIconic := False; EnumWindows(@ForegroundEnumWindowProc, 0); if (lhTargetHandle <> 0) then begin if (lbIsIconic) then begin //最小化されていたら元に戻す。 SendMessage(lhTargetHandle, WM_SYSCOMMAND, WPARAM(SC_RESTORE and $FFF0), 0); end; //前面に移動させる。 SetForegroundWindow(lhTargetHandle); //前面に移動させたので新規に実行する必要はない lbProgramDone := True; end; end; if not(lbProgramDone) then begin //新規実行 gpcQuoatExecute(ls_Exe); end; end; procedure TApp_TOOLBmpCaptureEx.Action_ProgramAddExecute(Sender: TObject); var i : Integer; ls_File : String; l_Bitmap : TBitmap; begin if (gfnbKeyState(VK_SHIFT)) then begin //Program Filesフォルダ Dialog_Program.InitialDir := gfnsProgramFilesPathGet; end; Dialog_Program.FileName := ''; // if (Dialog_Program.Execute) then begin Dialog_Program.InitialDir := gfnsFilePathGet(Dialog_Program.FileName); ls_File := UpperCase(Dialog_Program.FileName); for i := 0 to ComboBox_Program.Items.Count-1 do begin if (UpperCase(ComboBox_Program.Items[i]) = ls_File) then begin gpcShowMessage(Format('%s'#13'は登録済みです', [gfnsFileNameGet(Dialog_Program.FileName)])); Exit; end; end; ComboBox_Program.Items.Add(Dialog_Program.FileName); l_Bitmap := TBitmap.Create; try gpcProgramIconAdd(ImageList_Program, Dialog_Program.FileName); finally l_Bitmap.Free; end; end; FCreateProgramMenu; end; procedure TApp_TOOLBmpCaptureEx.Action_ProgramDelExecute(Sender: TObject); { メニューで選んだアイテムをリストから検索して削除する。 SenderはActionではなくMenuItemになることに注意。 } var li_Index : Integer; ls_File : String; ls_Name : String; begin if not(Sender is TMenuItem) then begin Exit; end; //MenuItemのHintにAnsiStringに変換したファイル名を格納している ls_File := UpperCase(TMenuItem(Sender).Hint); li_Index := ComboBox_Program.Items.IndexOf(ls_File); if (li_Index >= 0) then begin ls_Name := gfnsFileNameGet(ComboBox_Program.Items[li_Index]); if (gfniMessageBoxYesNo(Format('%s'#13'をリストから削除しますか', [ls_Name])) = ID_YES) then begin ComboBox_Program.Items. Delete(li_Index); ImageList_Program.Delete(li_Index); end; end; FCreateProgramMenu; end; procedure TApp_TOOLBmpCaptureEx.FCreateProgramMenu; procedure _PrgMenuCreate(AMenuItem : TMenuItem; AOnClick : TNotifyEvent); var i : Integer; ls_Name : String; l_MenuItem : TMenuItem; begin for i := 0 to ComboBox_Program.Items.Count-1 do begin //頭に'__'をつけることでメニューカスタマイズから除外する ls_Name := gfnsAvailableName(Format('__%s', [AMenuItem.Name])); l_MenuItem := NewItem( gfnsFileNameGet(ComboBox_Program.Items[i]), //Caption 0, //ShortCut False, //Checked True, //Enabled AOnClick, //OnClickイベント 0, //HelpContext ls_Name //Name ); l_MenuItem.Hint := ComboBox_Program.Items[i]; l_MenuItem.OnDrawItem := MenuItem_DrawItem; l_MenuItem.OnMeasureItem := MenuItem_MeasureItem; AMenuItem.Add(l_MenuItem); end; end; begin myMenu.gpcMenuItemFree(MenuItem_Program, MenuItem_ProgramLine2.MenuIndex +1); myMenu.gpcMenuItemFree(Menu_Program); myMenu.gpcMenuItemFree(MenuItem_ProgramDel); myMenu.gpcMenuItemFree(Menu_ProgramDel); _PrgMenuCreate(MenuItem_Program, Action_ProgramRunExecute); _PrgMenuCreate(Menu_Program.Items, Action_ProgramRunExecute); _PrgMenuCreate(MenuItem_ProgramDel, Action_ProgramDelExecute); _PrgMenuCreate(Menu_ProgramDel.Items, Action_ProgramDelExecute); Action_Program.Enabled := (ComboBox_Program.Items.Count > 0); Action_ProgramDel.Enabled := Action_Program.Enabled; end; procedure TApp_TOOLBmpCaptureEx.MenuItem_AdvancedDrawItem(Sender: TObject; ACanvas: TCanvas; ARect: TRect; State: TOwnerDrawState); begin myMenu.MenuItem_AdvancedDrawItem(Sender, ACanvas, ARect, State); end; procedure TApp_TOOLBmpCaptureEx.MenuItem_DrawItem(Sender: TObject; ACanvas: TCanvas; ARect: TRect; Selected: Boolean); begin myMenu.MenuItem_SendToDrawItem(Sender, ACanvas, ARect, Selected); end; procedure TApp_TOOLBmpCaptureEx.MenuItem_MeasureItem(Sender: TObject; ACanvas: TCanvas; var Width, Height: Integer); begin myMenu.MenuItem_MeasureItem(Sender, ACanvas, Width, Height); end; procedure TApp_TOOLBmpCaptureEx.Action_ShowToolBarExecute(Sender: TObject); begin ToolBar_Main.Visible := Action_ShowToolBar.Checked; FormResize(nil); end; procedure TApp_TOOLBmpCaptureEx.Action_ShowStatusBarExecute(Sender: TObject); begin if (Action_ShowStatusBar.Checked) then begin Panel_Frame.Align := alNone; Panel_Bottom.Align := alNone; StatusBar_Hint.Align := alNone; end; StatusBar_Hint.Visible := Action_ShowStatusBar.Checked; if (Action_ShowStatusBar.Checked) then begin StatusBar_Hint.Align := alBottom; Panel_Bottom.Align := alBottom; Panel_Frame.Align := alBottom; end; FormResize(nil); end; procedure TApp_TOOLBmpCaptureEx.Action_ShowHintPopupExecute(Sender: TObject); begin Self.ShowHint := Action_ShowHintPopup.Checked; end; //------------------------------------------------------------------------------ function _FormExists : Boolean; var i : Integer; begin if not(Assigned(App_TOOLBmpCaptureEx)) then begin Result := False; end else begin Result := False; for i := 0 to Screen.FormCount-1 do begin if (Screen.Forms[i] is TApp_TOOLBmpCaptureEx) then begin Result := True; Break; end; end; end; end; procedure _CreateForm; begin CreateForm(Application); end; procedure CreateForm(AOwner : TComponent);// ASaveEvent: TNotifyEvent = nil; ASaveMenu: TPopupMenu = nil); begin if not(_FormExists) then begin App_TOOLBmpCaptureEx := TApp_TOOLBmpCaptureEx.CreateSubForm(AOwner);//, ASaveEvent, ASaveMenu); end; end; procedure ShowForm; begin _CreateForm; App_TOOLBmpCaptureEx.Show; end; procedure CloseForm; //閉じる(破棄はしない) begin if (_FormExists) then begin App_TOOLBmpCaptureEx.Close; end; end; procedure RleaseForm; //破棄。 begin if (_FormExists) then begin App_TOOLBmpCaptureEx.Release; end; end; //------------------------------------------------------------------------------ procedure Capture(sFileName : WideString; fTime : TRefTime = 0); {キャプチャ実行。 sFileNameはファイル名。WideStringなのでユニコードな文字を含むファイル名もOK。 fTimeは秒数。例えば90を指定すると1分30秒の位置の映像をキャプチャする。 } begin //Form_Captureが作成されていなければ作成する。 _CreateForm; if not(App_TOOLBmpCaptureEx.Visible) then begin App_TOOLBmpCaptureEx.Show; end; App_TOOLBmpCaptureEx.PauseAndCapture(sFileName, fTime); end; procedure CopyImage; //クリップボードへコピー begin _CreateForm; App_TOOLBmpCaptureEx.Action_EditCopyExecute(nil); end; procedure SaveImage; begin _CreateForm; App_TOOLBmpCaptureEx.Action_FileSaveAsExecute(nil); end; procedure TApp_TOOLBmpCaptureEx.Action_FrameBackExecute(Sender: TObject); var li_Move : Integer; li_Index : Integer; l_Panel : TPanel; begin if not(FbSampleGrabber) then begin li_Move := 0; end else if (Sender = Action_FrameBack) then begin li_Move := -1; end else if (Sender = Action_FrameNext) then begin li_Move := +1; end else begin Exit; end; li_Index := gfniNumLimit(FGetFrameIndex + li_Move, 0, High(FBitmap)); l_Panel := gfnFindControl(Panel_Frame, Format('Panel_%d', [li_Index])) as TPanel; if (l_Panel <> nil) then begin Image_0Click(l_Panel); end; end; procedure TApp_TOOLBmpCaptureEx.Timer_CaptureTimer(Sender: TObject); var l_MediaControl : IMediaControl; begin if not(FbSampleGrabber) and (FbCapture) then begin if (FiImageIndex > High(FBitmap)) then begin // Action_PlayPauseExecute(nil); Timer_Capture.Enabled := False; FiImageIndex := -1; Timer_TimeTimer(nil); if (FbPause) then begin Action_PlayPauseExecute(nil); end; end else begin try // FGraphBuilder.QueryInterface(IMediaControl, l_MediaControl); if (FfCaptureTime <= FfVideoTime) then begin // Timer_Capture.Enabled := False; FGetBitmap; Inc(FiImageIndex); // l_MediaControl.Run; // Timer_Capture.Enabled := True; end else begin FfCaptureTime := FGetStepTime(1); // FMediaPosition.put_CurrentPosition(FfCaptureTime); // l_MediaControl.StopWhenReady; end; finally l_MediaControl := nil; end; end; end else begin //AIU Timer_Capture.Enabled := False; end; end; procedure TApp_TOOLBmpCaptureEx.Action_CaptureSampleGrabberExecute(Sender: TObject); var l_MediaControl : IMediaControl; l_State : TFilterState; lb_Captured : Boolean; begin if (Action_FileClose.Enabled) then begin FbResume := True; FfMediaPosition := 0; if (Assigned(FMediaPosition)) then begin FMediaPosition.get_CurrentPosition(FfMediaPosition); end; FbMediaPlay := False; if (Assigned(FGraphBuilder)) then begin FGraphBuilder.QueryInterface(IMediaControl, l_MediaControl); try if (l_MediaControl.GetState(100, l_State) = S_OK) then begin FbMediaPlay := (l_State = State_Running); end; finally l_MediaControl := nil; end; end; lb_Captured := Action_CaptureNext.Enabled; FOpen(FsFileName); Action_CaptureBack.Enabled := lb_Captured; Action_CaptureNext.Enabled := Action_CaptureBack.Enabled; end; end; end.