Как извлечь кадр из видео файла?
// Способ первый
uses
DirectShow9, ActiveX;
/// Время в секундах
/// Путь к файлу
/// Холст, на который выводится изображение
/// True - вписать в размер холста; False - оригинальный размер
{ Работает не со всеми форматами файлов }
function GetFrame( FrameTime: Double; const VideoFileName: string; Image: TCanvas;
Stretch: Boolean = False ): HRESULT;
var
MediaDet: IMediaDet;
MediaType: TAMMediaType;
VideoStreams: Integer;
BufferSize: Integer;
Buffer: PByte;
VideoWidth, VideoHeight: Integer;
BMIHeader: PBitmapInfoHeader;
BMPInfo: BitmapInfo;
PData: pointer;
HDCDest: HDC;
StreamTime: Double;
BitmapHdl: HBITMAP;
NewBitmap: TBitmap;
FLastErrorMessage: string;
begin
Result := S_FALSE;
try
if CoCreateInstance( CLSID_MediaDet, nil, CLSCTX_INPROC, IMediaDet, MediaDet ) = S_OK then
begin
try
if ( MediaDet.put_Filename( VideoFileName ) = S_OK ) and
( MediaDet.get_OutputStreams( VideoStreams ) = S_OK ) and
( VideoStreams > 0 ) and
( MediaDet.put_CurrentStream( 0 ) = S_OK ) and
( MediaDet.get_StreamMediaType( MediaType ) = S_OK ) and
( MediaDet.get_StreamLength( StreamTime ) = S_OK ) then
begin
if StreamTime >= FrameTime then
StreamTime := FrameTime;
VideoWidth := PVideoInfoHeader( MediaType.pbFormat )^.bmiHeader.biWidth;
VideoHeight := PVideoInfoHeader( MediaType.pbFormat )^.bmiHeader.biHeight;
if Failed( MediaDet.GetBitmapBits( StreamTime, @buffersize, nil, VideoWidth, VideoHeight ) ) then
begin
// FLastErrorMessage := 'GetBitmapBits(StreamTime, @buffersize, nil, VideoWidth, VideoHeight) failed - ' + VideoFileName;
Exit;
end;
GetMem( Buffer, BufferSize );
try
if Failed( MediaDet.GetBitmapBits( StreamTime, @buffersize, Buffer, VideoWidth, VideoHeight ) ) then
begin
// FLastErrorMessage := 'GetBitmapBits(StreamTime, @buffersize, Buffer, VideoWidth, VideoHeight) failed - ' + VideoFileName;
Exit;
end;
BMIHeader := PBitmapInfoHeader( Buffer );
Inc( BMIHeader );
pData := BMIHeader;
BMIHeader := PBitmapInfoHeader( Buffer );
ZeroMemory( @BMPInfo, SizeOf( BITMAPINFO ) );
CopyMemory( @BMPInfo.bmiHeader, bmiHeader, SizeOf( TBITMAPINFOHEADER ) );
HDCDest := GetDC( 0 );
if HDCDest = 0 then
begin
// FLastErrorMessage := 'HDCDest = 0 - ' + VideoFileName;
Exit;
end;
try
BitmapHdl := CreateDIBitmap( HDCDest, BMIHeader^, CBM_INIT, pData, BMPInfo, DIB_RGB_COLORS );
if BitmapHdl = 0 then
begin
// FLastErrorMessage := 'CreateDIBitmap failed - ' + VideoFileName;
Exit;
end
else
begin
NewBitmap := TBitmap.Create;
try
NewBitmap.Handle := BitmapHdl;
if Stretch then
Image.StretchDraw( Image.ClipRect, NewBitmap )
// Image.CopyRect( Image.ClipRect, NewBitmap.Canvas, NewBitmap.Canvas.ClipRect )
else
Image.CopyRect( TVideoInfoHeader( MediaType.pbFormat^ ).rcSource,
NewBitmap.Canvas, NewBitmap.Canvas.ClipRect );
finally
NewBitmap.Free;
end;
end;
finally
ReleaseDC( 0, HDCDest );
end;
finally
FreeMem( Buffer );
end;
end
else
begin
if MediaDet.put_Filename( VideoFileName ) <> S_OK then
FLastErrorMessage := 'MediaDet.put_Filename(' + VideoFileName + ') failed.'
else
if MediaDet.get_OutputStreams( VideoStreams ) <> S_OK then
FLastErrorMessage := 'MediaDet.get_OutputStreams(' + IntToStr( VideoStreams ) + ') failed.'
else
if VideoStreams <= 0 then
FLastErrorMessage := 'VideoStreams = ' + IntToStr( VideoStreams )
else
if MediaDet.put_CurrentStream( 0 ) <> S_OK then
FLastErrorMessage := 'MediaDet.put_CurrentStream(0) failed.'
else
if MediaDet.get_StreamMediaType( MediaType ) <> S_OK then
FLastErrorMessage := 'MediaDet.get_StreamMediaType(MediaType) failed.'
else
if MediaDet.get_StreamLength( StreamTime ) <> S_OK then
FLastErrorMessage := 'MediaDet.get_StreamLength(StreamTime) failed.'
else
FLastErrorMessage := 'Unknown Error.';
Exit;
end;
finally
MediaDet := nil;
end;
end;
Result := S_OK;
except on E: Exception do
FLastErrorMessage := E.Message;
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
GetFrame( 173, 'c:\test.mp4', Canvas );
end;
// Способ второй
// Смысл кода в том, что для воспроизведения видеофайла нужно создать граф,
// который создается из фильтров. Фильтр - это некий интерфейс, который может
// кодировать, декодировать и воспроизводить видео/аудио. Граф - это правильно
// подобраный набор фильтров для воспроизведения определенного потока и соорудить
// его самому очень сложная задача. Но есть у DirectShow функция RenderFile, которая
// создает граф для вывода в собственное небольшое окно. Это окно удаляется и на его
// место ставится свой граббер.
{ Работает не со всеми форматами файлов }
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, ExtCtrls, StdCtrls, DirectShow9, ActiveX;
type
TForm1 = class(TForm)
Button1: TButton;
Timer1: TTimer;
procedure Button1Click(Sender: TObject);
procedure Timer1Timer(Sender: TObject);
private
{ Private declarations }
FGraphBuilder: ICaptureGraphBuilder2;
FFilterGraph: IFilterGraph2;
FSampleGrabber: ISampleGrabber;
FMediaPosition: IMediaPosition;
FBasicAudio: IBasicAudio;
//video frame
FAVIWidth: integer;
FAVIHeight: integer;
FFrameBitmapInfoHeader: TBitmapInfoHeader;
FFrameData: array of byte;
//Bitmap, в который перемещаются кадры видео
FAVIBitmap: HBITMAP;
FAVIBitmapDC: HDC;
FAVIDIBData: Pointer;
//FAVIDrawDib: HDRAWDIB;
public
{ Public declarations }
procedure OpenFile( Path: string );
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
procedure TForm1.Button1Click(Sender: TObject);
begin
OpenFile( 'h:\Download\1\A Girl Watcher''s Paradise Vol. 5071.wmv' );
Timer1.Interval := 10;
Timer1.Enabled := True;
end;
procedure TForm1.OpenFile(Path: string);
procedure Check( Res: HResult );
begin
if ( Res <> S_OK ) and ( Res <> VFW_S_PARTIAL_RENDER ) then
raise Exception.Create( IntToStr( Res ) );
end;
procedure FindPin( baseFilter: IBaseFilter;
direction: PIN_DIRECTION;
pinNumber: Integer;
out destPin: IPin );
var
enumPins: IEnumPins;
numFound: Cardinal;
tmpPin: IPin;
pinDirection: PIN_DIRECTION;
begin
destPin := nil;
if baseFilter.EnumPins( enumPins ) = S_OK then
begin
while enumPins.Next( 1, tmpPin, @numFound ) = S_OK do
begin
tmpPin.QueryDirection( pinDirection );
if pinDirection = direction then
begin
if pinNumber = 0 then
begin
// Return the pin's interface
destPin := tmpPin;
Break;
end
else
DestPin := nil;
Dec( pinNumber );
end;
tmpPin := nil;
end;
end;
end;
function ConnectPins( outputFilter: IBaseFilter;
outputNum: Cardinal;
inputFilter: IBaseFilter;
inputNum: Cardinal ): Boolean;
var
inputPin, outputPin: IPin;
begin
if ( outputFilter = nil ) or ( inputFilter = nil ) then
begin
Result := False;
Exit;
end;
FindPin( outputFilter, PINDIR_OUTPUT, outputNum, outputPin );
FindPin( inputFilter, PINDIR_INPUT, inputNum, inputPin );
if ( outputPin = nil ) or ( InputPin = nil ) then
Check( -1 );
Check( FFilterGraph.Connect( outputPin, inputPin ) );
Result := True;
end;
const
MaxGraphRunAttempts = 100;
var
bmi: BITMAPINFO;
BitmapHeader: BITMAPINFOHEADER;
WideStr: WideString;
RunGraphAttempts: Integer;
grabberFilter, nullRenderer: IBaseFilter;
desiredType, connectedType: AM_MEDIA_TYPE;
infoHeader: VIDEOINFOHEADER;
mediaControl: IMediaControl;
pfs: _FilterState;
BufSize: Integer;
OutputPin, inputPin: IPin;
EnumFilters: IEnumFilters;
VideoRenderer, TmpFilter: IBaseFilter;
TmpGUID: TGUID;
begin
// Create the main object that runs the graph
Check( CoCreateInstance( CLSID_CaptureGraphBuilder2, nil, CLSCTX_INPROC_SERVER,
IID_ICaptureGraphBuilder2, FGraphBuilder ) );
// Create filter graph
Check( CoCreateInstance( CLSID_FilterGraph, nil, CLSCTX_INPROC_SERVER,
IID_IFilterGraph, FFilterGraph ) );
// Convert file name to unicode
WideStr := Path;
// Render whole graph
Check( FFilterGraph.RenderFile( PWideChar( WideStr ), nil ) );
// Seeking for default renderer window
VideoRenderer := nil;
FFilterGraph.EnumFilters( EnumFilters );
while EnumFilters.Next( 1, TmpFilter, @BufSize ) = S_OK do
begin
if TmpFilter.GetClassID( TmpGUID ) = S_OK then
begin
if IsEqualGUID( TmpGUID, CLSID_VideoMixingRenderer ) or
IsEqualGUID( TmpGUID, CLSID_VideoRendererDefault ) then
begin
VideoRenderer := TmpFilter;
Break;
end;
end;
end;
if VideoRenderer = nil then
raise Exception.Create( 'No video decoders found' );
// Find video output pin and disconnect default video renderer
FindPin( VideoRenderer, PINDIR_INPUT, 0, inputPin );
Check( inputPin.ConnectedTo( OutputPin ) );
FFilterGraph.RemoveFilter( VideoRenderer );
// Create the Sample Grabber to take frames
Check( CoCreateInstance( CLSID_SampleGrabber, nil, CLSCTX_INPROC_SERVER,
IID_IBaseFilter, GrabberFilter ) );
Check( grabberFilter.QueryInterface( IID_ISampleGrabber, FSampleGrabber ) );
Check( FFilterGraph.AddFilter( grabberFilter, 'Sample Grabber' ) );
// Set the 24-bit RGB desire here
// So that the proper conversion filters
// Are added automatically.
FillMemory( @DesiredType, Sizeof( desiredType ), 0 );
desiredType.majortype := MEDIATYPE_Video;
desiredType.subtype := MEDIASUBTYPE_RGB24;
desiredType.formattype := FORMAT_VideoInfo;
Check( FSampleGrabber.SetMediaType( desiredType ) );
Check( FSampleGrabber.SetBufferSamples( True ) );
// Connect grabber to video output
FindPin( grabberFilter, PINDIR_INPUT, 0, inputPin );
Check( FFilterGraph.Connect( OutputPin, inputPin ) );
// A Null Renderer does not display the video
// But it allows the Sample Grabber to run
// And it will keep proper playback timing
// Unless specified otherwise.
Check( CoCreateInstance( CLSID_NullRenderer, nil, CLSCTX_INPROC_SERVER,
IID_IBaseFilter, nullRenderer ) );
Check( FFilterGraph.AddFilter( nullRenderer, 'New Null Renderer' ) );
ConnectPins( grabberFilter, 0, nullRenderer, 0 );
// Video resolution
Check( FSampleGrabber.GetConnectedMediaType( connectedType ) );
if not IsEqualGUID( connectedType.formattype, FORMAT_VideoInfo ) then
raise Exception.Create( 'Cannot get video info' );
infoHeader := VIDEOINFOHEADER( connectedType.pbFormat^ );
FAVIWidth := infoHeader.bmiHeader.biWidth;
FAVIHeight := infoHeader.bmiHeader.biHeight;
FFrameBitmapInfoHeader := infoHeader.bmiHeader;
CoTaskMemFree( connectedType.pbFormat );
Check( FFilterGraph.QueryInterface( IID_IMediaControl, MediaControl ) );
// Tell the whole graph to start sending video
if mediaControl.Run <> S_OK then
begin
RunGraphAttempts := 0;
while mediaControl.GetState( 100, pfs ) <> S_OK do
begin
Sleep( 100 );
Inc( RunGraphAttempts );
if RunGraphAttempts > MaxGraphRunAttempts then
raise Exception.Create( 'Cannot play graph' );
end;
end;
ZeroMemory( @bmi, SizeOf( bmi ) );
ZeroMemory( @BitmapHeader, SizeOf( BitmapHeader ) );
with bmi.bmiHeader do
begin
biSize := SizeOf( BITMAPINFOHEADER );
biPlanes := 1;
biBitCount := 24;
biWidth := FAVIWidth;
biHeight := FAVIHeight;
biCompression := BI_RGB;
end;
FAVIBitmapDC := CreateCompatibleDC( 0 );
FAVIBitmap := CreateDIBSection( FAVIBitmapDC, bmi, DIB_RGB_COLORS, FAVIDIBData, 0, 0 );
SelectObject( FAVIBitmapDC, FAVIBitmap );
end;
procedure TForm1.Timer1Timer(Sender: TObject);
var
ErrCode, DibDataSize: Integer;
begin
if FSampleGrabber = nil then
Exit;
FSampleGrabber.GetCurrentBuffer( DibDataSize, nil );
Assert( DibDataSize = FAVIWidth * FAVIHEight * 3 );
ErrCode := FSampleGrabber.GetCurrentBuffer( DibDataSize, FAVIDIBData );
StretchBlt( Canvas.Handle, 0, 0, FAVIWidth, FAVIHEight, FAVIBitmapDC, 0, 0,
FAVIWidth, FAVIHeight, SRCCOPY );
end;
end.
|