// ******************************************************************************

// TVideoCapture -  wrapper for DirectShow video capture functions

// Based on

// Microsoft's AMCap & StillCap

// and

// DScapture by orthkon * www.mp3.com/orthkon * orthkon@mail.com

//

// written by Egor Averchenkov, 2001-2002,

// e_g_o_r@mail.ru

//

// version 1.15

// ******************************************************************************

// License Agreement

//

// Permission to use, copy, modify, and distribute this software and its

// documentation for any purpose and without fee is hereby granted,

// provided that the above copyright notice appears in all copies and

// that both the above copyright notice and this permission notice appear

// in supporting documentation, and that the name the author

// not be used in advertising or publicity pertaining to distribution of

// the software without specific, written prior permission. This

// software is made available "as is", and AUTHOR DISCLAIM

// ALL WARRANTIES, EXPRESS OR IMPLIED, WITH REGARD TO THIS SOFTWARE,

// INCLUDING WITHOUT LIMITATION ALL IMPLIED WARRANTIES OF MERCHANTABILITY

// AND FITNESS FOR A PARTICULAR PURPOSE, AND IN NO EVENT SHALL AUTHORS BE

// LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR ANY

// DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS,

// WHETHER IN AN ACTION OF CONTRACT, TORT (INCLUDING NEGLIGENCE) OR

// STRICT LIABILITY, ARISING OUT OF OR IN CONNECTION WITH THE USE OR

// PERFORMANCE OF THIS SOFTWARE.

//

// In other words - feel free to use this code)))

// I hope someone find it usefull. If you do - send me a message, pls.

// (Beer messages would be appreciated a lot!!! :o) )

// ******************************************************************************

// History log:



// 01-04-24 - v1.00 (initial release)



// 01-09-18 - v1.02 -  I had to continue this work after a long delay

// some stupid bugs corrected

// interface section was slightly ordered

// new property CapturePixelFormat added to select color depth of captured bitmaps



// 01-09-20 - v1.03 - orthkon mailed me TCapture based on this component - good work!

// added properties and functions to work with available capture modes



// 01-09-22 - v1.04

// working with filters property pages



// 01-10-18 - v1.05

// working with compressors        if ParCam[1].Vignette.Visible then  if ParCam[1].Vignette.Visible then



// 01-10-27 - v1.06 - thanks to Lee_Nover (Lee.Nover@email.si) - he did all dirty work))))

// one graph for preview/capture

// compression dialogs



// 01-10-28 - v1.07

// bugs in building graph with compressors were corrected



// 01-11-23 - v1.08

// completely rewriten graph building/controlling functions

// new properties:

// IsDV - Indicates DV Capture source is used

// WantDVAudio - Force using DV Audio stream to capture audio

// when DV device is used for capturing



// Sorry but I've changed some names(((



// 01-11-25 - v1.09

// saving/restoring capture graph configuration



// 02-05-25 - v1.10

// some bugs corrected

// graph restoring/building algorithms slightly ordered

// new properties:

// VCompDevice - name of video compressor used

// ACompDevice - name of audio compressor used

// VCapDevice  - name of video capture device used

// ACapDevice  - name of audio capture device used

// VCapIndex   - index of video capture device used

// ACapIndex   - index of audio capture device used

// VCompIndex  - index of video compressor device used

// ACompIndex  - index of audio compressor device used

// ACapModeIdx - index of audio capture mode used

// VCapModeIdx - index of video capture mode used



// 02-10-10 - v1.11

// 1. added SampleGrabber buffer locking functions to avoid

// simultaneous access from different threads to buffer data

// 2. added OnFramePassed event firing every time frame comes

// through SampleGrabber



// 02-10-13 - v1.12

// only BCB support added to sources



// 02-10-16 - v1.13

// added WantAudioPreview property to disable audio preview rendering

// added OnAborted event to indicate graph run aborted for some reason

// added OnDeviceLost event to indicate capture device lost during preview/capture

// some optimization done



// 02-10-20 - v1.14

// some bugs in working with the capture and compressor lists corrected



// 02-11-03 - v1.15

// bugs when working with DV capture devices corrected

// bug in rendering graph with WantAudioPreview property corrected

// bug in working with the capture and compressor lists corrected

// ******************************************************************************

// Known problems.



// Some audio compressor filters do not expose IAMStreamControl

// (it's pitty but ACM Wrapper does not((( ) so component can't correctly

// start/stop capture part of graph using such filters.

// It's recomended to use native DShow audio compressors to capture avi.

// ******************************************************************************

Unit VCap;



Interface



// -----------------------------------------------------------------------------

// BCB support

{$NOINCLUDE ActiveX}

{$NOINCLUDE DirectShowVC}

{$HPPEMIT '/* don''t use DirectShow.pas in C++ sources - use native C++ headers!!! */' }

{$HPPEMIT '#define Directshow ' }

{$HPPEMIT '#include <strmif.h>' }

{$HPPEMIT '#include <control.h>' }

{$HPPEMIT 'typedef System::DelphiInterface<IGraphBuilder> _di_IGraphBuilder;'}

{$HPPEMIT 'typedef System::DelphiInterface<ICaptureGraphBuilder2> _di_ICaptureGraphBuilder2;' }

{$HPPEMIT 'typedef System::DelphiInterface<IVideoWindow> _di_IVideoWindow;' }

{$HPPEMIT 'typedef System::DelphiInterface<IMediaEventEx> _di_IMediaEventEx;' }

{$HPPEMIT 'typedef System::DelphiInterface<IAMDroppedFrames> _di_IAMDroppedFrames;' }

{$HPPEMIT 'typedef System::DelphiInterface<IAMVfwCaptureDialogs> _di_IAMVfwCaptureDialogs;' }

{$HPPEMIT 'typedef System::DelphiInterface<IAMVfwCompressDialogs> _di_IAMVfwCompressDialogs;' }

{$HPPEMIT 'typedef System::DelphiInterface<IAMStreamConfig> _di_IAMStreamConfig;' }

{$HPPEMIT 'typedef System::DelphiInterface<IBaseFilter> _di_IBaseFilter;' }

{$HPPEMIT 'typedef System::DelphiInterface<IFileSinkFilter> _di_IFileSinkFilter;' }

{$HPPEMIT 'typedef System::DelphiInterface<IConfigAviMux> _di_IConfigAviMux;' }

{$HPPEMIT 'typedef System::DelphiInterface<IUnknown> _di_ISampleGrabber; // to use ISampleGrabber include <qedit.h>' }



Uses

  Windows, Messages, SysUtils, Classes, Graphics, Controls, extctrls,

  ActiveX, DirectShowVC;



// -----------------------------------------------------------------------------

// Windows messages

Const

  WM_FGNOTIFY       = WM_USER + 1;

  WM_SAMPLECAPTURED = WM_USER + 2;

  WM_SAMPLEPASSED   = WM_USER + 3;



  // message WM_SAMPLECAPTURED

Type

  TWMSampleCaptured = Packed Record

    Msg: Cardinal;

    GrabberCB: TObject;

    LParam: Longint;

    Result: Longint;

  End;



  // -----------------------------------------------------------------------------

Type

  EVideoCaptureError = Class(Exception);



Type

  TCapturedBitmap = Class(TBitmap); // to eliminate some problems with BCB



Type

  TBitmapCapturedEvent = Procedure(CapturedImage: TCapturedBitmap) Of Object;



Type

  TDVResolution = (dvrDontWorry, dvrFull, dvrHalf, dvrQuater, dvrDC);



  // -----------------------------------------------------------------------------

  // Working with capture modes

Type

  TVCapMode = Record

    MediaType: TGUID;

    MediaSubType: TGUID;

    Width: integer;

    Height: integer;

    BitCount: integer;

    FrameRate, MinFrameRate, MaxFrameRate: double;

  End;



Type

  TACapMode = Record

    MediaType: TGUID;

    MediaSubType: TGUID;

    SampleRate: integer;

    SampleSize: integer;

    Channels: integer;

    AvgSampleRate: integer;

  End;



Function IsEqualModes(Const mode1, mode2: TVCapMode): boolean; Overload;

Function IsEqualModes(Const mode1, mode2: TACapMode): boolean; Overload;



Function GetModeString(Const mode: TVCapMode): String; Overload;

Function GetModeString(Const mode: TACapMode): String; Overload;



// -----------------------------------------------------------------------------

// Various Capture Dialog Types

Type

  TCaptureDialog = (cdVFORMAT, cdVSOURCE, cdVDISPLAY, cdVCAPTURE, cdVCROSSBAR, cdTVTUNER, cdACAPTURE, cdACROSSBAR,

    cdTVAUDIO, cdVCAPTURE_PIN, cdVPREVIEW_PIN, cdACAPTURE_PIN, cdVCOMPRESSION, cdACOMPRESSION);

  TCaptureDialogs = Set Of TCaptureDialog;



  // -----------------------------------------------------------------------------

  // TVideoCapture component

Type



  TGraphConfig = Class;



  TVideoCapture = Class(TCustomControl)

  Private

    Graph:           IGraphBuilder;

    Builder:         ICaptureGraphBuilder2;

    VideoWindow:     IVideoWindow;

    MediaEvent:      IMediaEventEx;

    DroppedFrames:   IAMDroppedFrames;

    CaptureDialogs:  IAMVfwCaptureDialogs;

    CompressDialogs: IAMVfwCompressDialogs;

    AStreamConf:     IAMStreamConfig; // for audio capture

    VStreamConf:     IAMStreamConfig; // for video capture



    Render: IBaseFilter;            // file writer

    VCap, ACap,                     // capture filters

    VComp, AComp,                   // compressor filters

    DVSplitter, DVDec: IBaseFilter; // filters to use with DV devices

    Sink:              IFileSinkFilter;

    NullRenderer:      IBaseFilter;

    ConfigAviMux:      IConfigAviMux;

    Grabber:           ISampleGrabber;



    GrabberCB: TObject;



    FCCAvail:    boolean;

    FCapCC:      boolean;

    FGraphBuilt: boolean;



    FACapFriendlyName, FVCapFriendlyName: String;



    FCapturing:    boolean;

    FPreviewing:   boolean;

    FUseFrameRate: boolean;

    FUseTimeLimit: boolean;

    FFrameRate:    double;

    FCapStartTime: DWORD;

    FCapStopTime:  DWORD;

    FMasterStream: integer;



    FNotDropped:     integer;

    FDroppedFrames:  integer;

    FNotDroppedBase: integer;

    FDroppedBase:    integer;

    FCapTime:        DWORD;



    mVideo, mAudio, mVComp, mAComp: IMoniker;

    FCaptureTimer:                  TTimer;



    FDialogs:        TCaptureDialogs;

    FDoPreallocFile: boolean;



    FTempCaptureFileName: String;

    FCaptureFileName:     String;

    FTimeLimit:           integer;

    FUseTempFile:         boolean;

    FPreallocFileSize:    Cardinal;

    FCaptureFile:         WideString;

    FDVResolution:        TDVResolution;



    FOnStopPreview:      TNotifyEvent;

    FOnStartPreview:     TNotifyEvent;

    FOnStopCapture:      TNotifyEvent;

    FOnStartCapture:     TNotifyEvent;

    FOnChangeDevice:     TNotifyEvent;

    FOnCaptureProgress:  TNotifyEvent;

    FOnBitmapGrabbed:    TBitmapCapturedEvent;

    FOnChangeACapMode:   TNotifyEvent;

    FOnChangeVCapMode:   TNotifyEvent;

    FOnChangeCompressor: TNotifyEvent;

    FOnFrameRendered:    TNotifyEvent;

    FOnDeviceLost:       TNotifyEvent;

    FOnAborted:          TNotifyEvent;



    FPixelFormat:      TPixelFormat;

    FWantPreview:      boolean;

    FWantCapture:      boolean;

    FWantAudio:        boolean;

    FWantDVAudio:      boolean;

    FWantBitmaps:      boolean;

    FWantAudioPreview: boolean;



    Procedure SetMasterStream(Const Value: integer);

    Property MasterStream: integer Read FMasterStream Write SetMasterStream;

    Procedure SetFrameRate(Const Value: double);

    Procedure SetTempCaptureFileName(Const Value: String);

    Procedure SetCaptureFileName(Const Value: String);

    Function GetACapMode: TACapMode;

    Function GetACapModeCount: integer;

    Function GetACapModes(i: integer): TACapMode;

    Function GetVCapMode: TVCapMode;

    Function GetVCapModeCount: integer;

    Function GetVCapModes(i: integer): TVCapMode;

    Function GetIsDVSource: boolean;

    Procedure SetDVResolution(Const Value: TDVResolution);

    Function GetACapSource: String;

    Function GetVCapSource: String;

    Function GetACompDevice: String;

    Function GetVCompDevice: String;

    Function GetACapSourceIdx: integer;

    Function GetACompDeviceIdx: integer;

    Function GetVCapSourceIdx: integer;

    Function GetVCompDeviceIdx: integer;

    Function GetACapModeIdx: integer;

    Function GetVCapModeIdx: integer;

  Private

    Procedure SetSize(Var Msg: TMessage); Message WM_SIZE; // Changing size of cap window

    Procedure GraphEvent(Var Msg: TMessage); Message WM_FGNOTIFY;

    Procedure BitmapGrabbed(Var Msg: TWMSampleCaptured); Message WM_SAMPLECAPTURED;

    Procedure FramePassed(Var Msg: TMessage); Message WM_SAMPLEPASSED; // sample passed through SampleGrabber

    Procedure CaptureProgress(Sender: TObject);

    Procedure ResizeWindow;

    Procedure UpdateStatus;

    Procedure ChooseDevices(nmVideo, nmAudio: IMoniker; ForceGraphRebuild: boolean = false); Overload;

    Procedure ChooseCompressors(nmVComp, nmAComp: IMoniker; ForceGraphRebuild: boolean = false); Overload;

    Procedure DoAborted(hr: HRESULT);

    Procedure DoDeviceLost;



    Procedure CleanUp;

    Procedure FreeCapFilters;

    Function InitCapFilters: boolean;

    Function MakeBuilder: boolean;

    Function MakeGraph: boolean;

    Procedure NukeDownstream(pf: IBaseFilter);

    Procedure TearDownGraph;

    Function FindVideoWindow: boolean;

    Function RenderVideoPreview(Const VSource: IBaseFilter): boolean;

    Function BuildGraph: boolean;

    Function ControlCaptureStream(start: boolean): boolean;



    Function AllocCaptureFile(Const SizeMb: integer): boolean;

    Function SaveCaptureFile(Const FileName: String): boolean;

    Procedure GetAvailableDialogs;

  Public

    // if someone wants to work with DShow objects

    Property CaptureGraph: IGraphBuilder Read Graph;

    Property VCapFilter:   IBaseFilter Read VCap;

    Property ACapFilter:   IBaseFilter Read ACap;

    Property VCompFilter:  IBaseFilter Read VComp;

    Property ACompFilter:  IBaseFilter Read AComp;



    // graph state properties

    Property Capturing:  boolean Read FCapturing;  // is capturing now

    Property Previewing: boolean Read FPreviewing; // is previewing now



    // video capture properties

    Property VCapFriendlyName: String Read FVCapFriendlyName;

    Property VCapName:         String Read GetVCapSource; // used video capture device name

    Property VCapIndex:        integer Read GetVCapSourceIdx;



    Property VCapMode:              TVCapMode Read GetVCapMode; // current video capture mode

    Property VCapModeIdx:           integer Read GetVCapModeIdx; // current video capture mode index

    Property VCapModeCount:         integer Read GetVCapModeCount; // available video capture mode count

    Property VCapModes[i: integer]: TVCapMode Read GetVCapModes;

    Function SetVCapMode(i: integer): boolean; Overload;

    Function SetVCapMode(Const mode: TVCapMode): boolean; Overload;



    // audio capture properties

    Property ACapFriendlyName: String Read FACapFriendlyName;

    Property ACapName: String Read GetACapSource; // used audio capture device name

    Property ACapIndex: integer Read GetACapSourceIdx;



    Property ACapMode: TACapMode Read GetACapMode;         // current audio capture mode

    Property ACapModeIdx: integer Read GetACapModeIdx;     // current audio capture mode index

    Property ACapModeCount: integer Read GetACapModeCount; // available audio capture mode count

    Property ACapModes[i: integer]: TACapMode Read GetACapModes;

    Function SetACapMode(i: integer): boolean; Overload;

    Function SetACapMode(Const mode: TACapMode): boolean; Overload;



    // compressors properties

    Property VCompName: String Read GetVCompDevice;      // used video compressor name

    Property VCompIndex: integer Read GetVCompDeviceIdx; // used video compressor index

    Property ACompName: String Read GetACompDevice;      // used audio compressor name

    Property ACompIndex: integer Read GetACompDeviceIdx; // used audio compressor index



    // other properties

    Property IsDVSource: boolean Read GetIsDVSource; // indicates DV capture source is used

    Property Dialogs: TCaptureDialogs Read FDialogs; // available graph dialogs

    Property FramesDropped: integer Read FDroppedFrames;

    Property NotDropped: integer Read FNotDropped;

    Property CapStartTime: DWORD Read FCapStartTime;

    Property CapStopTime: DWORD Read FCapStopTime;

    Property CapTime: DWORD Read FCapTime;



    Procedure ChooseDevices(Const szVideo, szAudio: String; ForceGraphRebuild: boolean = false); Overload;

    Procedure ChooseDevices(Const numVideo, numAudio: integer; ForceGraphRebuild: boolean = false); Overload;



    Procedure ChooseCompressors(Const szVComp, szAComp: String; ForceGraphRebuild: boolean = false); Overload;

    Procedure ChooseCompressors(Const numVComp, numAComp: integer; ForceGraphRebuild: boolean = false); Overload;



    Function Init: boolean; // you have to call this routine first!!!

    Function StartPreview: boolean;

    Function StopPreview: boolean;

    Function StartCapture(Const Dialog: boolean = false): boolean;

    Function StopCapture: boolean;

    Function CaptureFrame: boolean;



    Function ShowDialog(Const DialogType: TCaptureDialog): boolean;



    Procedure SaveGraph(config: TGraphConfig);

    Procedure RestoreGraph(config: TGraphConfig);



    Constructor Create(AOwner: TComponent); Override;

    Destructor Destroy; Override;

  Published

    Property DVResolution: TDVResolution Read FDVResolution Write SetDVResolution;



    // set to true if you want to capture single frames during preview

    Property WantBitmaps:       boolean Read FWantBitmaps Write FWantBitmaps;

    Property BitmapPixelFormat: TPixelFormat Read FPixelFormat Write FPixelFormat;



    Property WantAudio:   boolean Read FWantAudio Write FWantAudio; // set true if you want audio in captured file

    Property WantDVAudio: boolean Read FWantDVAudio Write FWantDVAudio;

    // set true if you want DV audio in captured file

    Property WantAudioPreview: boolean Read FWantAudioPreview Write FWantAudioPreview;

    // set true if you want render audio preview

    Property WantPreview: boolean Read FWantPreview Write FWantPreview;

    Property WantCapture: boolean Read FWantCapture Write FWantCapture;

    // set to false if dont want capture file is being created

    Property UseFrameRate:        boolean Read FUseFrameRate Write FUseFrameRate;

    Property FrameRate:           double Read FFrameRate Write SetFrameRate;

    Property CaptureFileName:     String Read FCaptureFileName Write SetCaptureFileName;

    Property UseTempFile:         boolean Read FUseTempFile Write FUseTempFile;

    Property TempCaptureFileName: String Read FTempCaptureFileName Write SetTempCaptureFileName;

    Property UseTimeLimit:        boolean Read FUseTimeLimit Write FUseTimeLimit;

    Property TimeLimit:           integer Read FTimeLimit Write FTimeLimit;

    Property DoPreallocFile:      boolean Read FDoPreallocFile Write FDoPreallocFile;

    Property PreallocFileSize:    Cardinal Read FPreallocFileSize Write FPreallocFileSize Default 10;



    Property OnAborted:          TNotifyEvent Read FOnAborted Write FOnAborted; // if normal graph run has been aborted

    Property OnDeviceLost:       TNotifyEvent Read FOnDeviceLost Write FOnDeviceLost; //

    Property OnChangeDevice:     TNotifyEvent Read FOnChangeDevice Write FOnChangeDevice;

    Property OnChangeCompressor: TNotifyEvent Read FOnChangeCompressor Write FOnChangeCompressor;

    Property OnChangeVCapMode:   TNotifyEvent Read FOnChangeVCapMode Write FOnChangeVCapMode;

    Property OnChangeACapMode:   TNotifyEvent Read FOnChangeACapMode Write FOnChangeACapMode;

    Property OnCaptureProgress:  TNotifyEvent Read FOnCaptureProgress Write FOnCaptureProgress;

    Property OnStopCapture:      TNotifyEvent Read FOnStopCapture Write FOnStopCapture;

    Property OnStopPreview:      TNotifyEvent Read FOnStopPreview Write FOnStopPreview;

    Property OnStartCapture:     TNotifyEvent Read FOnStartCapture Write FOnStartCapture;

    Property OnStartPreview:     TNotifyEvent Read FOnStartPreview Write FOnStartPreview;

    Property OnBitmapGrabbed:    TBitmapCapturedEvent Read FOnBitmapGrabbed Write FOnBitmapGrabbed;

    Property OnFrameRendered:    TNotifyEvent Read FOnFrameRendered Write FOnFrameRendered;

  Published

    Property Align;

    Property Color;

    Property Visible;

    Property OnMouseMove;

    Property OnMouseUp;

    Property OnMouseDown;

    Property OnClick;

    Property OnDblClick;

  End;



  TGraphConfig = Class

  Public

    VCapSource: String;

    ACapSource: String;

    VComp:      String;

    AComp:      String;

    ACapMode:   TACapMode;

    VCapMode:   TVCapMode;

    VCompState: String;



    WantCapture:      boolean;

    WantPreview:      boolean;

    WantBitmaps:      boolean;

    WantAudio:        boolean;

    WantDVAudio:      boolean;

    WantAudioPreview: boolean;



    PixelFormat:  TPixelFormat;

    DVResolution: TDVResolution;



    CaptureFileName:     String;

    UseTempFile:         boolean;

    TempCaptureFileName: String;

    DoPreallocFile:      boolean;

    PreallocFileSize:    Cardinal;



    Procedure Clear;

    Procedure RestoreGraph(layout: String);

    Function RestoreGraphFromStream(Stream: TStream): boolean;

    Function SaveGraph: String;

    Function SaveGraphToStream(Stream: TStream): boolean;



    Constructor Create;

  End;



  // device enum functions

  // callers have to free aquired lists!!!

Function GetVideoDevicesList(Const Refresh: boolean = false): TStringList;

Function GetAudioDevicesList(Const Refresh: boolean = false): TStringList;

Function GetVideoCompressorsList(Const Refresh: boolean = false): TStringList;

Function GetAudioCompressorsList(Const Refresh: boolean = false): TStringList;



Implementation



Uses VCapStrings, Utils, Dialogs, MMSystem, contnrs, syncobjs;





// -----------------------------------------------------------------

// const

// MAX_TIME: TReference_Time = $7FFFFFFFFFFFFFFF;



// my filter names to find these filters in the graph

Const

  VCompFilterName         = 'MyVideoCompressor';

  ACompFilterName         = 'MyAudioCompressor';

  DVSplitterFilterName    = 'MyDVSplitter';

  DVDecoderFilterName     = 'MyDVDecoder';

  SmartTeeFilterName      = 'MySmartTee';

  InfTeeFilterName        = 'MyInfTee';

  SampleGrabberFilterName = 'MyBitmapGrabber';

  NullRendererFilterName  = 'MyNullRenderer';



Const

  IID_IPropertyBag: TGUID          = '{55272A00-42CB-11CE-8135-00AA004BB851}';

  IID_ISpecifyPropertyPages: TGUID = '{B196B28B-BAB4-101A-B69C-00AA00341D07}';



Const

  VfwCompressDialog_Config = 1;

  VfwCompressDialog_About  = 2;

  // returns S_OK if the dialog exists and can be shown, else S_FALSE

  VfwCompressDialog_QueryConfig = 4;

  VfwCompressDialog_QueryAbout  = 8;



Const

  AM_FILE_OVERWRITE = 1;



  // DV Modes

Const

  DVResolutions: Array [TDVResolution] Of integer = (0, DVRESOLUTION_FULL, DVRESOLUTION_HALF, DVRESOLUTION_QUARTER,

    DVRESOLUTION_DC);



Type

  TDVRes = Record

    DVWidth, DVHeight, DVBits: integer;

  End;



Const

  DVRes: Array [DVRESOLUTION_FULL .. DVRESOLUTION_DC] Of TDVRes = ((DVWidth: 720; DVHeight: 576; DVBits: 24), // Full

    (DVWidth: 360; DVHeight: 288; DVBits: 24), // Half

    (DVWidth: 180; DVHeight: 144; DVBits: 24), // quater

    (DVWidth: 88; DVHeight: 72; DVBits: 24)    // DC

    );



Const

  DVRes1: Array [DVRESOLUTION_FULL .. DVRESOLUTION_DC] Of TDVResolution = (dvrFull, dvrHalf, dvrQuater, dvrDC);



Const

  DVCapModesCount = High(DVRes) - Low(DVRes) + 1;



  // used to install SampleGrabber

Const

  PixelFormatGUIDs: Array [TPixelFormat] Of PGUID = (@MEDIASUBTYPE_RGB24, @MEDIASUBTYPE_RGB1, @MEDIASUBTYPE_RGB4,

    @MEDIASUBTYPE_RGB8, @MEDIASUBTYPE_RGB555, @MEDIASUBTYPE_RGB565, @MEDIASUBTYPE_RGB24, @MEDIASUBTYPE_RGB32,

    @MEDIASUBTYPE_RGB24);



  // -----------------------------------------------------------------

Function MyMsg(szMsg: String; hr: HRESULT): String;

Begin

  Result := Format(szMsg, [hr]);

  MessageBox(GetForegroundWindow, PChar(Result), PChar(rsDShowCapture), MB_OK Or MB_ICONSTOP);

End;



Procedure ErrMsg(szMsg: String; hr: HRESULT = 0);

Begin

  MyMsg(szMsg, hr);

End;



Procedure ErrMsgException(szMsg: String; hr: HRESULT = 0);

Begin

  Raise EVideoCaptureError.Create(MyMsg(szMsg, hr));

End;



// -----------------------------------------------------------------

Function CheckGUID(Const p1, p2: TGUID): boolean;

Var

  i: byte;

Begin

  Result := false;

  For i  := 0 To 7 Do

    If p1.D4[i] <> p2.D4[i] Then

      Exit;

  Result := (p1.D1 = p2.D1) And (p1.D2 = p2.D2) And (p1.D3 = p2.D3);

End;



// Free an existing media type (ie free resources it holds)

Procedure FreeMediaType(mt: TAM_MEDIA_TYPE);

Begin

  If mt.cbFormat <> 0 Then

  Begin

    CoTaskMemFree(mt.pbFormat);

    // Strictly unnecessary but tidier

    mt.cbFormat := 0;

    mt.pbFormat := Nil;

  End;

  mt.pUnk := Nil;

End;



Procedure DeleteMediaType(pmt: PAM_MEDIA_TYPE);

Begin

  // allow NULL pointers for coding simplicity

  If pmt <> Nil Then

  Begin

    FreeMediaType(pmt^);

    CoTaskMemFree(pmt);

  End;

End;



// -----------------------------------------------------------------

Function IsEqualModes(Const mode1, mode2: TVCapMode): boolean;

Begin

  Result := CheckGUID(mode1.MediaSubType, mode2.MediaSubType) And (mode1.Height = mode2.Height) And

    (mode1.Width = mode2.Width) And (mode1.BitCount = mode2.BitCount);

End;



Function IsEqualModes(Const mode1, mode2: TACapMode): boolean;

Begin

  Result := CheckGUID(mode1.MediaSubType, mode2.MediaSubType);

  If Result Then

  Begin

    If CheckGUID(mode1.MediaSubType, MEDIASUBTYPE_PCM) Then

      Result := (mode1.SampleRate = mode2.SampleRate) And (mode1.SampleSize = mode2.SampleSize) And

        (mode1.Channels = mode2.Channels)

    Else

      Result := (mode1.AvgSampleRate = mode2.AvgSampleRate) And (mode1.SampleRate = mode2.SampleRate) And

        (mode1.Channels = mode2.Channels);

  End;

End;



Function GetModeString(Const mode: TVCapMode): String; Overload;

Type

  TSubTypeName = Record

    SubType: PGUID;

    Name: String;

  End;

Const

  MediaSubTypeNames: Array [1 .. 13] Of TSubTypeName = ((SubType: @MEDIASUBTYPE_YVU9; Name: '(YVU9)'),

    (SubType: @MEDIASUBTYPE_Y411; Name: '(Y411)'), (SubType: @MEDIASUBTYPE_Y41P; Name: '(Y41P)'),

    (SubType: @MEDIASUBTYPE_YUY2; Name: '(YUY2)'), (SubType: @MEDIASUBTYPE_YVYU; Name: '(YVYU)'),

    (SubType: @MEDIASUBTYPE_UYVY; Name: '(UYVY)'), (SubType: @MEDIASUBTYPE_Y211; Name: '(Y211)'),

    (SubType: @MEDIASUBTYPE_RGB24; Name: '(RGB24)'), (SubType: @MEDIASUBTYPE_RGB32; Name: '(RGB32)'),

    (SubType: @MEDIASUBTYPE_RGB565; Name: '(RGB565)'), (SubType: @MEDIASUBTYPE_RGB555; Name: '(RGB555)'),

    (SubType: @MEDIASUBTYPE_ARGB32; Name: '(ARGB32)'), (SubType: @MEDIASUBTYPE_RGB565; Name: '(RGB565)'));

Var

  i: integer;

Begin

  Result := Format('%dx%dx%db', [mode.Width, mode.Height, mode.BitCount]);

  For i  := Low(MediaSubTypeNames) To High(MediaSubTypeNames) Do

    If CheckGUID(mode.MediaSubType, MediaSubTypeNames[i].SubType^) Then

    Begin

      Result := Result + ' ' + MediaSubTypeNames[i].Name;

      break;

    End;

End;



Function GetModeString(Const mode: TACapMode): String; Overload;

Begin

  If CheckGUID(mode.MediaSubType, MEDIASUBTYPE_PCM) Then

  Begin

    Result := Format('%dHzx%dbx%d', [mode.SampleRate, mode.SampleSize, mode.Channels]);

  End

  Else

  Begin

    Result := Format('%dkBits/s, %dHz, %d', [mode.AvgSampleRate * 8 Div 1000, mode.SampleRate, mode.Channels]);

  End;

End;



// -----------------------------------------------------------------

{ TCapDeviceInfo }

Type

  TCapDeviceInfo = Class

  Public

    DeviceName:       String;

    DeviceNameInList: String;

    Moniker:          IMoniker;

    Constructor Create(Const aDeviceName, aDeviceNameInList: String; Const aMoniker: IMoniker);

    Destructor Destroy; Override;

  End;



Constructor TCapDeviceInfo.Create(Const aDeviceName, aDeviceNameInList: String; Const aMoniker: IMoniker);

Begin

  DeviceName       := aDeviceName;

  DeviceNameInList := aDeviceNameInList;

  Moniker          := aMoniker;

End;



Destructor TCapDeviceInfo.Destroy;

Begin

  Moniker := Nil; // I guess we have to release moniker - tnx to Gabriel Corneanu

  Inherited;

End;



// -----------------------------------------------------------------

Function GetIntByMoniker(list: TObjectList; aMoniker: IMoniker): integer;

Var

  i: integer;

Begin

  Result := -1;

  For i  := 0 To list.Count - 1 Do

    With list[i] As TCapDeviceInfo Do

      If aMoniker = Moniker Then

      Begin

        Result := i;

        break;

      End;

End;



Function GetStringByMoniker(list: TObjectList; aMoniker: IMoniker): String;

Var

  i: integer;

Begin

  Result := '';

  i      := GetIntByMoniker(list, aMoniker);

  If (i >= 0) Then

    With list[i] As TCapDeviceInfo Do

      Result := DeviceNameInList;

End;



Function GetMonikerByString(list: TObjectList; aString: String): IMoniker;

Var

  i: integer;

Begin

  Result := Nil;

  For i  := 0 To list.Count - 1 Do

    With list[i] As TCapDeviceInfo Do

      If aString = DeviceNameInList Then

      Begin

        Result := Moniker;

        break;

      End;

End;



// -----------------------------------------------------------------

Function FindDeviceNum(Const DeviceName: String; Devices: TObjectList): integer;

Var

  i: integer;

  d: TObject;

Begin

  Result := 1;

  For i  := 0 To Devices.Count - 1 Do

  Begin

    d := Devices[i];

    If (d Is TCapDeviceInfo) And (TCapDeviceInfo(d).DeviceName = DeviceName) Then

      Result := Result + 1;

  End;

End;



Procedure EnumFilters(Const clsidDeviceClass: TGUID; Const FiltersList: TObjectList);

Var

  SysDevEnum: ICreateDevEnum;

  EnumCat:    IEnumMoniker;

  Moniker:    IMoniker;

  PropBag:    IPropertyBag;

  varName:    OleVariant;

  n:          integer;

  s:          String;

Begin

  FiltersList.Clear;

  If (CoCreateInstance(CLSID_SystemDeviceEnum, Nil, CLSCTX_INPROC, IID_ICreateDevEnum, SysDevEnum) = S_OK) Then

  Begin

    // enum available video capture devices

    If (SysDevEnum.CreateClassEnumerator(clsidDeviceClass, EnumCat, 0) = S_OK) Then

      While EnumCat.Next(1, Moniker, Nil) = S_OK Do

      Begin

        If (Moniker.BindToStorage(Nil, Nil, IID_IPropertyBag, PropBag) = S_OK) And (PropBag <> Nil) Then

        Begin

          PropBag.Read('FriendlyName', varName, Nil);

          s := varName;

          If Trim(s) <> '' Then

          Begin

            n := FindDeviceNum(s, FiltersList);

            If n > 1 Then

              s := s + Format(' (%d)', [n]);

            FiltersList.Add(TCapDeviceInfo.Create(varName, s, Moniker));

          End;

        End;

      End;

  End;

End;



// -----------------------------------------------------------------

Var

  VideoDevicesList, AudioDevicesList, VideoCompressorsList, AudioCompressorsList: TObjectList;



Procedure BuildVideoDevicesList;

Begin

  EnumFilters(CLSID_VideoInputDeviceCategory, VideoDevicesList);

End;



Procedure BuildAudioDevicesList;

Begin

  EnumFilters(CLSID_AudioInputDeviceCategory, AudioDevicesList);

End;



Procedure BuildVideoCompressorsList;

Begin

  EnumFilters(CLSID_VideoCompressorCategory, VideoCompressorsList);

End;



Procedure BuildAudioCompressorsList;

Begin

  EnumFilters(CLSID_AudioCompressorCategory, AudioCompressorsList);

End;



Procedure BuildDevicesList;

Begin

  BuildVideoDevicesList;

  BuildAudioDevicesList;

  BuildVideoCompressorsList;

  BuildAudioCompressorsList;

End;



Procedure ClearDevicesList;

Begin

  VideoDevicesList.Clear;

  AudioDevicesList.Clear;

  VideoCompressorsList.Clear;

  AudioCompressorsList.Clear;

End;



// -----------------------------------------------------------------

// devices Enum functions

Function GetVideoDevicesList(Const Refresh: boolean): TStringList;

Var

  i: integer;

Begin

  If Refresh Or (VideoDevicesList.Count = 0) Then

    BuildVideoDevicesList;

  Result := TStringList.Create;

  Try

    For i := 0 To VideoDevicesList.Count - 1 Do

      Result.Add(TCapDeviceInfo(VideoDevicesList[i]).DeviceNameInList);

  Except

    Result.Free;

    Raise;

  End;

End;



Function GetAudioDevicesList(Const Refresh: boolean): TStringList;

Var

  i: integer;

Begin

  If Refresh Or (AudioDevicesList.Count = 0) Then

    BuildAudioDevicesList;

  Result := TStringList.Create;

  Try

    For i := 0 To AudioDevicesList.Count - 1 Do

      Result.Add(TCapDeviceInfo(AudioDevicesList[i]).DeviceNameInList);

  Except

    Result.Free;

    Raise;

  End;

End;



Function GetVideoCompressorsList(Const Refresh: boolean = false): TStringList;

Var

  i: integer;

Begin

  If Refresh Or (VideoCompressorsList.Count = 0) Then

    BuildVideoCompressorsList;

  Result := TStringList.Create;

  Try

    For i := 0 To VideoCompressorsList.Count - 1 Do

      Result.Add(TCapDeviceInfo(VideoCompressorsList[i]).DeviceNameInList);

  Except

    Result.Free;

    Raise;

  End;

End;



Function GetAudioCompressorsList(Const Refresh: boolean = false): TStringList;

Var

  i: integer;

Begin

  If Refresh Or (AudioCompressorsList.Count = 0) Then

    BuildAudioCompressorsList;

  Result := TStringList.Create;

  Try

    For i := 0 To AudioCompressorsList.Count - 1 Do

      Result.Add(TCapDeviceInfo(AudioCompressorsList[i]).DeviceNameInList);

  Except

    Result.Free;

    Raise;

  End;

End;



// -----------------------------------------------------------------

{ TSampleGrabberCB - ISampleGrabberCB realization }

Type

  TSampleGrabberCB = Class(TObject, ISampleGrabberCB)

  Private

    FBuffer:  PByte;

    FBuffLen: Cardinal;

    FOwner:   HWND;

    FEnable:  boolean;

    FLock:    TCriticalSection;

  Public

    { IUnknown }

    Function QueryInterface(Const IID: TGUID; Out Obj): HRESULT; Stdcall;

    Function _AddRef: integer; Stdcall;

    Function _Release: integer; Stdcall;

    { ISampleGrabberCB }

    Function SampleCB(SampleTime: double; pSample: IMediaSample): HRESULT; Stdcall;

    Function BufferCB(SampleTime: double; pBuffer: PByte; BufferLen: Longint): HRESULT; Stdcall;

  Public

    Property Owner:           HWND Read FOwner Write FOwner;

    Property Buffer:          PByte Read FBuffer;

    Property BufferLength:    Cardinal Read FBuffLen;

    Property GrabbingEnabled: boolean Read FEnable Write FEnable;



    Procedure ClearBuffer;

    // to avoid access to buffer from other thread

    // before accessing to buffer need to disable access to it

    // don't forget to enable access after using buffer data!

    Procedure DisableBufferAccess;

    Procedure EnableBufferAccess;



    Constructor Create;

    Destructor Destroy; Override;

  End;



  { TSampleGrabberCB }

Constructor TSampleGrabberCB.Create;

Begin

  FBuffer  := Nil;

  FBuffLen := 0;

  FLock    := TCriticalSection.Create;

End;



Destructor TSampleGrabberCB.Destroy;

Begin

  ClearBuffer;

  FLock.Free;

  Inherited;

End;



Procedure TSampleGrabberCB.DisableBufferAccess;

Begin

  FLock.Enter;

End;



Procedure TSampleGrabberCB.EnableBufferAccess;

Begin

  FLock.Leave;

End;



Procedure TSampleGrabberCB.ClearBuffer;

Begin

  DisableBufferAccess;

  Try

    FBuffLen := 0;

    ReallocMem(FBuffer, FBuffLen);

  Finally

    EnableBufferAccess;

  End;

End;



{ TSampleGrabberCB - IUnknown }

Function TSampleGrabberCB._AddRef: integer;

Begin

  Result := 2;

End;



Function TSampleGrabberCB._Release: integer;

Begin

  Result := 1;

End;



Function TSampleGrabberCB.QueryInterface(Const IID: TGUID; Out Obj): HRESULT;

Begin

  // We need to return the two event interfaces when they're asked for

  Result := E_NOINTERFACE;

  If CheckGUID(IID, ISampleGrabberCB) Or CheckGUID(IID, IUnknown) Then

  Begin

    If GetInterface(IID, Obj) Then

      Result := S_OK;

  End;

End;



{ TSampleGrabberCB - ISampleGrabberCB }

Function TSampleGrabberCB.SampleCB(SampleTime: double; pSample: IMediaSample): HRESULT;

Begin // not implemented

  Result := S_OK;

End;



Function TSampleGrabberCB.BufferCB(SampleTime: double; pBuffer: PByte; BufferLen: integer): HRESULT;

Begin

  If GrabbingEnabled Then

  Begin

    // Comment from microsoft programmer below

    // The sample grabber is calling us back on its deliver thread.

    // This is NOT the main app thread!

    //

    // !!!!! WARNING WARNING WARNING !!!!!

    //

    // On Windows 9x systems, you are not allowed to call most of the

    // Windows API functions in this callback.  Why not?  Because the

    // video renderer might hold the global Win16 lock so that the video

    // surface can be locked while you copy its data.  This is not an

    // issue on Windows 2000, but is a limitation on Win95,98,98SE and ME.

    // Calling a 16-bit legacy function could lock the system, because

    // it would wait forever for the Win16 lock, which would be forever

    // held by the video renderer.

    // As a workaround, we will copy the bitmap data during the callback,

    // post a message to our app, and write the data later.

    GrabbingEnabled := false;

    DisableBufferAccess;

    Try

      ReallocMem(FBuffer, BufferLen);

      FBuffLen := BufferLen;

      CopyMemory(FBuffer, pBuffer, BufferLen);

    Finally

      EnableBufferAccess;

    End;

    // notify application frame buffer filled

    PostMessage(FOwner, WM_SAMPLECAPTURED, integer(Self), 0);

  End;

  // notify application that next frame arrived

  PostMessage(FOwner, WM_SAMPLEPASSED, integer(Self), 0);

  Result := S_OK;

End;



// -----------------------------------------------------------------

{ TVideoCapture }

Constructor TVideoCapture.Create(AOwner: TComponent);

Begin

  Inherited;

  CleanUp;

  FUseFrameRate     := false;

  FWantAudio        := true;

  FWantAudioPreview := true;

  FWantDVAudio      := true;

  FWantPreview      := true;

  FWantCapture      := true;

  FWantBitmaps      := true;

  Color             := clBlue;

  Width             := 100;

  Height            := 100;

  FPreallocFileSize := 1;

  FPixelFormat      := pf24bit;



  GrabberCB := TSampleGrabberCB.Create;



  FCaptureTimer          := TTimer.Create(Self);

  FCaptureTimer.Interval := 100;

  FCaptureTimer.OnTimer  := CaptureProgress;

End;



Destructor TVideoCapture.Destroy;

Begin

  StopPreview;

  StopCapture;

  TearDownGraph;

  CleanUp;



  FCaptureTimer.Enabled := false;

  FCaptureTimer.Free;

  GrabberCB.Free;



  // free resources occupied by lists

  ClearDevicesList;

  Inherited;

End;



// -----------------------------------------------------------------

Procedure TVideoCapture.ChooseDevices(nmVideo, nmAudio: IMoniker; ForceGraphRebuild: boolean = false);

Begin

  If (ForceGraphRebuild) Or ((mVideo <> nmVideo) Or (mAudio <> nmAudio)) Then

  Begin

    mVideo := nmVideo;

    mAudio := nmAudio;

    TearDownGraph;

    asm // this was added due to corrupted registers after func call (D5 compiler error?)

      push ebx; push edi; push esi

    end;

    InitCapFilters;

    asm

      pop esi; pop edi; pop ebx

    end;



    If BuildGraph And WantPreview Then

      StartPreview;

    Try

      If Assigned(FOnChangeDevice) Then

        FOnChangeDevice(Self);

    Except

    End;

  End;

End;



Procedure TVideoCapture.ChooseCompressors(nmVComp, nmAComp: IMoniker; ForceGraphRebuild: boolean);

Begin

  If (ForceGraphRebuild) Or ((mVComp <> nmVComp) Or (mAComp <> nmAComp)) Then

  Begin

    mVComp := Nil;

    mAComp := Nil;

    mVComp := nmVComp;

    mAComp := nmAComp;

    TearDownGraph;

    asm // this was added due to corrupted registers after func call (D5 compiler error?)

      push ebx; push edi; push esi

    end;

    InitCapFilters;

    asm

      pop esi; pop edi; pop ebx

    end;



    If BuildGraph And WantPreview Then

      StartPreview;

    Try

      If Assigned(FOnChangeCompressor) Then

        FOnChangeCompressor(Self);

    Except

    End;

  End;

End;



// -----------------------------------------------------------------

Procedure TVideoCapture.ChooseDevices(Const szVideo, szAudio: String; ForceGraphRebuild: boolean = false);

Var

  nmVideo, nmAudio: IMoniker;

Begin

  nmVideo := Nil;

  nmAudio := Nil;



  If (VideoDevicesList.Count = 0) Then

    BuildVideoDevicesList;

  If (AudioDevicesList.Count = 0) Then

    BuildAudioDevicesList;

  nmVideo := GetMonikerByString(VideoDevicesList, szVideo);

  nmAudio := GetMonikerByString(AudioDevicesList, szAudio);



  ChooseDevices(nmVideo, nmAudio, ForceGraphRebuild);

  nmVideo := Nil;

  nmAudio := Nil;

End;



Procedure TVideoCapture.ChooseDevices(Const numVideo, numAudio: integer; ForceGraphRebuild: boolean = false);

Var

  nmVideo, nmAudio: IMoniker;

Begin

  nmVideo := Nil;

  nmAudio := Nil;



  If (numVideo >= 0) And (numVideo < VideoDevicesList.Count) Then

    nmVideo := TCapDeviceInfo(VideoDevicesList[numVideo]).Moniker;

  If (numAudio >= 0) And (numAudio < AudioDevicesList.Count) Then

    nmAudio := TCapDeviceInfo(AudioDevicesList[numAudio]).Moniker;



  ChooseDevices(nmVideo, nmAudio, ForceGraphRebuild);

  nmVideo := Nil;

  nmAudio := Nil;

End;



Procedure TVideoCapture.ChooseCompressors(Const szVComp, szAComp: String; ForceGraphRebuild: boolean);

Var

  nmVComp, nmAComp: IMoniker;

Begin

  nmVComp := Nil;

  nmAComp := Nil;



  If (VideoCompressorsList.Count = 0) Then

    BuildVideoCompressorsList;

  If (AudioCompressorsList.Count = 0) Then

    BuildAudioCompressorsList;

  nmVComp := GetMonikerByString(VideoCompressorsList, szVComp);

  nmAComp := GetMonikerByString(AudioCompressorsList, szAComp);



  ChooseCompressors(nmVComp, nmAComp, ForceGraphRebuild);

  nmVComp := Nil;

  nmAComp := Nil;

End;



Procedure TVideoCapture.ChooseCompressors(Const numVComp, numAComp: integer; ForceGraphRebuild: boolean);

Var

  nmVComp, nmAComp: IMoniker;

Begin

  nmVComp := Nil;

  nmAComp := Nil;



  If (numVComp >= 0) And (numVComp < VideoCompressorsList.Count) Then

    nmVComp := TCapDeviceInfo(VideoCompressorsList[numVComp]).Moniker;

  If (numAComp >= 0) And (numAComp < AudioCompressorsList.Count) Then

    nmAComp := TCapDeviceInfo(AudioCompressorsList[numAComp]).Moniker;



  ChooseCompressors(nmVComp, nmAComp, ForceGraphRebuild);

  nmVComp := Nil;

  nmAComp := Nil;

End;



// -----------------------------------------------------------------

Procedure TVideoCapture.CleanUp;

Begin

  FreeCapFilters;



  VideoWindow   := Nil;

  MediaEvent    := Nil;

  DroppedFrames := Nil;



  Render       := Nil;

  Sink         := Nil;

  ConfigAviMux := Nil;

  NullRenderer := Nil;



  FCCAvail      := false;

  FCapCC        := false;

  FGraphBuilt   := false;

  FCapturing    := false;

  FPreviewing   := false;

  FMasterStream := -1;

End;



Procedure TVideoCapture.FreeCapFilters;

Begin

  Graph           := Nil;

  Builder         := Nil;

  VCap            := Nil;

  ACap            := Nil;

  DVSplitter      := Nil;

  DVDec           := Nil;

  VComp           := Nil;

  AComp           := Nil;

  AStreamConf     := Nil;

  VStreamConf     := Nil;

  CaptureDialogs  := Nil;

  CompressDialogs := Nil;

  Grabber         := Nil;

  FDialogs        := [];

End;



Function TVideoCapture.MakeBuilder: boolean;

Begin

  Result := (Builder <> Nil) Or (CoCreateInstance(CLSID_CaptureGraphBuilder2, Nil, CLSCTX_INPROC,

    IID_ICaptureGraphBuilder2, Builder) = NOERROR);

End;



Function TVideoCapture.MakeGraph: boolean;

Begin

  Result := (Graph <> Nil) Or (CoCreateInstance(CLSID_FilterGraph, Nil, CLSCTX_INPROC, IID_IGraphBuilder, Graph)

    = NOERROR);

End;



Function TVideoCapture.Init: boolean;

Begin

  // Create the filter graph and create the capture graph builder.

  Result := MakeGraph And MakeBuilder;

  If Not Result Then

    Exit;



  Builder.SetFiltergraph(Graph);

  BuildDevicesList;

  Result := (VideoDevicesList.Count > 0); // or (AudioDevicesList.Count>0);

End;



Function TVideoCapture.InitCapFilters: boolean;

Var

  PropBag: IPropertyBag;

  hr:      HRESULT;

  varOle:  OleVariant;

  Pin:     IPin;

  AStream: IBaseFilter;

Begin

  FreeCapFilters;



  Result := MakeBuilder;

  If Not Result Then

  Begin

    ErrMsg(rsCantMakeGraphBuilder);

    Exit;

  End;



  DVSplitter := Nil;

  DVDec      := Nil;



  Try

    VCap := Nil;

    hr   := 0;

    If mVideo <> Nil Then

    Begin

      hr := mVideo.BindToStorage(Nil, Nil, IID_IPropertyBag, PropBag);

      If Succeeded(hr) Then

      Begin

        If PropBag.Read('FriendlyName', varOle, Nil) = NOERROR Then

          FVCapFriendlyName := varOle;

        PropBag             := Nil;

      End;

      hr := mVideo.BindToObject(Nil, Nil, IID_IBaseFilter, VCap);

    End;

    If VCap = Nil Then

      ErrMsgException(rsCantCreateVCaptureFilter, hr);



    // make a filtergraph, give it to the graph builder and put the video

    // capture filter in the graph

    If Not MakeGraph Then

      ErrMsgException(rsCantMakeGraph);



    If Builder.SetFiltergraph(Graph) <> NOERROR Then

      ErrMsgException(rsCantSetFilterGraph);



    If Graph.AddFilter(VCap, Nil) <> NOERROR Then

      ErrMsgException(rsCantAddVFilterToGraph, hr);



    // !!! What if this interface isn't supported?

    // we use this interface to set the frame rate and get the capture size

    hr := Builder.FindInterface(@PIN_CATEGORY_CAPTURE, @MEDIATYPE_Interleaved, VCap, IID_IAMStreamConfig, VStreamConf);

    If hr <> NOERROR Then

    Begin

      hr := Builder.FindInterface(@PIN_CATEGORY_CAPTURE, @MEDIATYPE_Video, VCap, IID_IAMStreamConfig, VStreamConf);

      If hr <> NOERROR Then // this means we can't set frame rate (non-DV only)

        ErrMsg(rsCantFindVStreamConfig, hr);

    End;



    If IsDVSource Then

    Begin

      // insert DVSplitter & DVDecoder if they are not exist

      If Failed(Graph.FindFilterByName(DVDecoderFilterName, DVDec)) Then

      Begin

        If Failed(CoCreateInstance(CLSID_DVVideoCodec, Nil, CLSCTX_INPROC, IID_IBaseFilter, DVDec)) Then

        Begin

          ErrMsgException(rsCantAddDVDecoder);

        End;

      End;

      If WantAudio And WantDVAudio Then

      Begin

        If Failed(Graph.FindFilterByName(DVSplitterFilterName, DVSplitter)) Then

        Begin

          If Failed(CoCreateInstance(CLSID_DVSplitter, Nil, CLSCTX_INPROC, IID_IBaseFilter, DVSplitter)) Then

          Begin

            ErrMsgException(rsCantAddDVSplitter);

          End;

        End;

      End;

    End;

    // we use this interface to bring up the 3 dialogs

    // NOTE:  Only the VfW capture filter supports this.  This app only brings

    // up dialogs for legacy VfW capture drivers, since only those have dialogs

    Builder.FindInterface(@PIN_CATEGORY_CAPTURE, @MEDIATYPE_Video, VCap, IID_IAMVfwCaptureDialogs, CaptureDialogs);



    // add video compression filter

    If WantCapture And (VCap <> Nil) And (mVComp <> Nil) Then

    Begin

      hr := mVComp.BindToObject(Nil, Nil, IID_IBaseFilter, VComp);

      If (hr = S_OK) Then

      Begin

        Builder.FindInterface(@PIN_CATEGORY_CAPTURE, @MEDIATYPE_Video, VComp, IID_IAMVfwCompressDialogs,

          CompressDialogs)

      End;

    End;



    // there's no point making an audio capture filter

    If WantAudio Then

    Begin

      // create the audio capture filter, even if we are not capturing audio right

      // now, so we have all the filters around all the time.

      // We want an audio capture filter and some interfaces

      If (DVSplitter = Nil) Then

      Begin // is not DV source

        If (mAudio <> Nil) Then

        Begin

          hr := mAudio.BindToStorage(Nil, Nil, IID_IPropertyBag, PropBag);

          If Succeeded(hr) Then

          Begin

            If PropBag.Read('FriendlyName', varOle, Nil) = NOERROR Then

              FACapFriendlyName := varOle;

            PropBag             := Nil;

          End;



          ACap := Nil;

          mAudio.BindToObject(Nil, Nil, IID_IBaseFilter, ACap);

          If ACap = Nil Then

            // there are no audio capture devices. We'll only allow video capture

            ErrMsg(rsCantMakeACapFilter)

          Else

          Begin

            // put the audio capture filter in the graph

            // We'll need this in the graph to get audio property pages

            If Graph.AddFilter(ACap, Nil) <> NOERROR Then

              ErrMsgException(rsCantAddAFilterToGraph, hr);

          End;

        End;

        AStream := ACap;

      End

      Else

      Begin

        AStream := DVSplitter;

      End;



      If (ACap <> Nil) Or (WantAudio And WantDVAudio) Then

      Begin

        // add audio compression filter

        If WantCapture And (mAComp <> Nil) And Succeeded(mAComp.BindToObject(Nil, Nil, IID_IBaseFilter, AComp)) Then

        Begin

          AStream := AComp // to control audio stream of AudioCompressor filter

        End;



        // !!! What if this interface isn't supported?

        // we use this interface to set the captured wave format

        hr := Builder.FindInterface(Nil, @MEDIATYPE_Audio, AStream, IID_IAMStreamConfig, AStreamConf);

        If (hr <> NOERROR) And Not(IsDVSource And (AStream = DVSplitter)) Then

          ErrMsg(rsCantFindAStreamConfig);

      End;

    End;



    // Can this filter do closed captioning?

    hr := Builder.FindPin(VCap, PINDIR_OUTPUT, PIN_CATEGORY_VBI, TGUID(Nil^), false, 0, Pin);

    If hr <> S_OK Then

      hr     := Builder.FindPin(VCap, PINDIR_OUTPUT, PIN_CATEGORY_CC, TGUID(Nil^), false, 0, Pin);

    FCCAvail := (hr = S_OK); // can't capture it, then

    If FCapCC Then

      Pin := Nil;



    Result := true;

  Except

    FreeCapFilters;

    Result := false;

  End;

End;



Procedure TVideoCapture.ResizeWindow;

Begin

  If Assigned(VideoWindow) Then

    VideoWindow.SetWindowPosition(0, 0, ClientWidth, ClientHeight);

End;



Procedure TVideoCapture.SetSize(Var Msg: TMessage);

Begin

  Inherited;

  ResizeWindow;

End;



Function TVideoCapture.FindVideoWindow: boolean;

Begin

  // Get the preview window to be a child of our app's window

  // This will find the IVideoWindow interface on the renderer.  It is

  // important to ask the filtergraph for this interface... do NOT use

  // ICaptureGraphBuilder2::FindInterface, because the filtergraph needs to

  // know we own the window so it can give us display changed messages, etc.

  Result := (Graph.QueryInterface(IID_IVideoWindow, VideoWindow) = S_OK);

  If Result Then

  Begin

    VideoWindow.put_Owner(Handle); // We own the window now

    VideoWindow.put_WindowStyle(WS_CHILD Or WS_CLIPSIBLINGS); // you are now a child

    // give the preview window all our space

    ResizeWindow;

    VideoWindow.put_Visible(true);

  End;

End;



Procedure TVideoCapture.DoAborted(hr: HRESULT);

Begin

  StopCapture;

  If Assigned(FOnAborted) Then

    FOnAborted(Self);

End;



Procedure TVideoCapture.DoDeviceLost;

Begin

  If Assigned(FOnDeviceLost) Then

    FOnDeviceLost(Self);

  StopCapture;

  StopPreview;

End;



// graph event occured - get & process events

Procedure TVideoCapture.GraphEvent(Var Msg: TMessage);

Var

  Event, param1, param2:       integer;

  wasCapturing, wasPreviewing: boolean;

Begin

  wasCapturing  := Capturing;

  wasPreviewing := Previewing;

  If (MediaEvent <> Nil) Then

  Begin

    While MediaEvent.GetEvent(Event, param1, param2, 0) = S_OK Do

    Begin

      Try

        // if you need parameters supplied by GetEvent function - process it here

        // case Event of

        // end;

      Finally

        MediaEvent.FreeEventParams(Event, param1, param2);

      End;

      Case Event Of

        EC_ERRORABORT:

          DoAborted(param1);

        EC_DEVICE_LOST:

          DoDeviceLost;

      End;

    End;

    // we have stopped capture now need to restore preview

    If ((Capturing <> wasCapturing) Or (wasPreviewing <> Previewing)) And (WantPreview) Then

    Begin

      StartPreview; // it will rebuild graph

    End;

  End;

End;



// we have to build video preview part of graph

// if we want to capture bitmaps need to render stream through grabber filter

Function TVideoCapture.RenderVideoPreview(Const VSource: IBaseFilter): boolean;

Var

  FGrabber: IBaseFilter;

  mt:       TAM_MEDIA_TYPE;

  flt:      IBaseFilter;

Begin

  flt := VSource;

  If WantBitmaps Then

  Begin

    Result := Succeeded(Graph.FindFilterByName(SampleGrabberFilterName, FGrabber)) Or // already exists

      ( // have to make new one

      (CoCreateInstance(CLSID_SampleGrabber, Nil, CLSCTX_INPROC, IID_IBaseFilter, FGrabber) = NOERROR) And

      (Graph.AddFilter(FGrabber, SampleGrabberFilterName) = S_OK));



    Result := Result And (FGrabber.QueryInterface(IID_ISampleGrabber, Grabber) = S_OK);



    If Result Then

    Begin

      If (FPixelFormat <> pfDevice) Then

      Begin

        // set prefered bitmap pixel depth

        ZeroMemory(@mt, sizeof(mt));

        mt.formattype := FORMAT_VideoInfo;

        mt.majortype  := MEDIATYPE_Video;

        mt.SubType    := PixelFormatGUIDs[FPixelFormat]^;

        Grabber.SetMediaType(mt);

      End;



      If Succeeded(Builder.RenderStream(Nil, @MEDIATYPE_Video, flt, Nil, FGrabber)) Then

      Begin

        Grabber.SetBufferSamples(false);

        Grabber.SetOneShot(false);

        TSampleGrabberCB(GrabberCB).Owner := Handle;

        Grabber.SetCallback(TSampleGrabberCB(GrabberCB), 1);

        flt := FGrabber;

      End

      Else

      Begin

        // we cant connect grabber - probably wrong mediatype?

        // TO DO: try to request DecoderOut available mediatypes and

        // set one of them

        ErrMsg(rsCantInstallSampleGrabber);

      End;



    End;

  End;

  Result := Succeeded(Builder.RenderStream(Nil, @MEDIATYPE_Video, flt, Nil, Nil));

End;



// Tear down everything downstream of a given filter

Procedure TVideoCapture.NukeDownstream(pf: IBaseFilter);

Var

  pP, pTo: IPin;

  pins:    IEnumPins;

  pininfo: TPIN_INFO;

  hr:      HRESULT;

Begin

  pins := Nil;

  hr   := pf.EnumPins(pins);

  pins.Reset;

  While hr = NOERROR Do

  Begin

    hr := pins.Next(1, pP, Nil);

    If (hr = S_OK) And (pP <> Nil) Then

    Begin

      pP.ConnectedTo(pTo);

      If pTo <> Nil Then

      Begin

        hr := pTo.QueryPinInfo(pininfo);

        If hr = NOERROR Then

        Begin

          If pininfo.dir = PINDIR_INPUT Then

          Begin

            NukeDownstream(pininfo.pFilter);

            Graph.Disconnect(pTo);

            Graph.Disconnect(pP);

            Graph.RemoveFilter(pininfo.pFilter);

          End;

          pininfo.pFilter := Nil;

        End;

        pTo := Nil;

      End;

      pP := Nil;

    End;

  End;

  pins := Nil;

End;



// Tear down everything downstream of the capture filters, so we can build

// a different capture graph.  Notice that we never destroy the capture filters

// and WDM filters upstream of them, because then all the capture settings

// we've set would be lost.

Procedure TVideoCapture.TearDownGraph;

Begin

  If Not FGraphBuilt Then

    Exit;

  If Capturing Then

    StopCapture;

  If Previewing Then

    StopPreview;



  If VideoWindow <> Nil Then

  Begin

    // stop drawing in our window, or we may get wierd repaint effects

    VideoWindow.put_Visible(false);

    VideoWindow.put_Owner(0);

  End;

  // free compressors and other filters we used

  VideoWindow   := Nil;

  Sink          := Nil;

  NullRenderer  := Nil;

  ConfigAviMux  := Nil;

  Render        := Nil;

  Grabber       := Nil;

  MediaEvent    := Nil;

  DroppedFrames := Nil;



  // destroy the graph downstream of our capture filters

  If VCap <> Nil Then

    NukeDownstream(VCap);

  If ACap <> Nil Then

    NukeDownstream(ACap);



  FGraphBuilt := false;

  If (WantCapture) Then

    DeleteFile(TempCaptureFileName);

End;



// build the preview graph!

// !!! PLEASE NOTE !!!  Some new WDM devices have totally separate capture

// and preview settings.  An application that wishes to preview and then

// capture may have to set the preview pin format using IAMStreamConfig on the

// preview pin, and then again on the capture pin to capture with that format.

// In this sample app, there is a separate page to set the settings on the

// capture pin and one for the preview pin.  To avoid the user

// having to enter the same settings in 2 dialog boxes, an app can have its own

// UI for choosing a format (the possible formats can be enumerated using

// IAMStreamConfig) and then the app can programmatically call IAMStreamConfig

// to set the format on both pins.



// build the capture graph!

Function TVideoCapture.BuildGraph: boolean;

Var

  hr:               HRESULT;

  pmt:              PAM_MEDIA_TYPE;

  SmartTee:         IBaseFilter;

  InfiniteTee:      IBaseFilter;

  VSource, ASource: IBaseFilter; // aliases to video/audio sources

  Sink2:            IFileSinkFilter2;

Begin

  // we have no GraphBuilder((

  Result := Assigned(Graph);

  If Not Result Then

    Exit;

  // we have one already

  Result := FGraphBuilt;

  If Result Then

    Exit;

  // Result = false



  // We don't have necessary capture filters

  If (VCap = Nil) Then

    Exit;

  If (WantAudio) And ((ACap = Nil) And (Not(IsDVSource And WantDVAudio))) Then

    Exit;



  If (WantCapture) Then

  Begin

    // no capture file name yet... we need one first

    If UseTempFile Then

      FCaptureFile := TempCaptureFileName

    Else

      FCaptureFile := CaptureFileName;



    If (FCaptureFile = '') Then

    Begin

      ErrMsg(rsEmptyFileName);

      Exit;

    End;



    DeleteFile(FCaptureFile);



    If FDoPreallocFile And Not AllocCaptureFile(PreallocFileSize) Then

    Begin

      ErrMsg(rsFailedToAllocFileSize);

      Exit;

    End;

  End;



  Try

    VSource := VCap;

    ASource := ACap;



    If IsDVSource Then

    Begin

      If (DVDec <> Nil) Then

        Graph.AddFilter(DVDec, DVDecoderFilterName);

      If (DVSplitter <> Nil) Then

        Graph.AddFilter(DVSplitter, DVSplitterFilterName);

      If (DVDec <> Nil) And (Builder.RenderStream(Nil, @MEDIATYPE_Interleaved, VCap, DVSplitter, DVDec) = S_OK) Then

      Begin

        SetDVResolution(FDVResolution);

        VSource := DVDec;

        If WantAudio And WantDVAudio Then

          ASource := DVSplitter;

      End

      Else

        ErrMsgException(rsCantRenderVCaptureStream);

    End;



    // insert Smart Tee Filter

    If Failed(CoCreateInstance(CLSID_SmartTee, Nil, CLSCTX_INPROC, IID_IBaseFilter, SmartTee)) Or

      Failed(Graph.AddFilter(SmartTee, SmartTeeFilterName)) Or

      Failed(Builder.RenderStream(Nil, @MEDIATYPE_Video, VSource, Nil, SmartTee)) Then

    Begin

      ErrMsgException(rsCantAddSmartTee);

    End;

    VSource := SmartTee;



    // Infinite Tee Filter

    If (ASource <> Nil) And (WantAudioPreview) Then

    Begin

      If Failed(CoCreateInstance(CLSID_InfTee, Nil, CLSCTX_INPROC, IID_IBaseFilter, InfiniteTee)) Or

        Failed(Graph.AddFilter(InfiniteTee, InfTeeFilterName)) Or

        Failed(Builder.RenderStream(Nil, @MEDIATYPE_Audio, ASource, Nil, InfiniteTee)) Then

      Begin

        ErrMsgException(rsCantAddInfTee);

      End;

      ASource := InfiniteTee;

    End;



    // Rendering audio preview stream

    If WantPreview And WantAudioPreview And (ASource <> Nil) Then

    Begin

      If Failed(Builder.RenderStream(Nil, @MEDIATYPE_Audio, ASource, Nil, Nil)) Then

        ErrMsgException(rsCantRenderAPreviewStream);

    End;



    If WantCapture Then

    Begin

      // if Succeeded(CoCreateInstance(CLSID_NullRenderer, nil, CLSCTX_INPROC, IID_IBaseFilter, NullRenderer)) then begin

      // Graph.AddFilter(NullRenderer, NullRendererFilterName);

      // end;

      // We need a rendering section that will write the capture file out in AVI file format

      hr := Builder.SetOutputFileName(MEDIASUBTYPE_Avi, PWCHAR(FCaptureFile), Render, Sink);

      If (hr <> NOERROR) Then

        ErrMsgException(rsCantSetCaptureFile);

      If Succeeded(Sink.QueryInterface(IID_IFileSinkFilter2, Sink2)) Then

      Begin

        // set overwrite mode for file sinker

        Sink2.SetMode(AM_FILE_OVERWRITE);

        Sink2 := Nil;

      End;

      // Now tell the AVIMUX to write out AVI files that old apps can read properly.

      // If we don't, most apps won't be able to tell where the keyframes are, slowing down editing considerably

      // Doing this will cause one seek (over the area the index will go) when

      // you capture past 1 Gig, but that's no big deal.

      // NOTE: This is on by default, so it's not necessary to turn it on

      hr := Render.QueryInterface(IID_IConfigAviMux, ConfigAviMux);

      If (hr = NOERROR) And (ConfigAviMux <> Nil) Then

      Begin

        ConfigAviMux.SetOutputCompatibilityIndex(true);

        If (ASource <> Nil) Then // Also, set the proper MASTER STREAM

          MasterStream := FMasterStream;

      End;



      If (VComp <> Nil) Then

        Graph.AddFilter(VComp, VCompFilterName);

      hr := Builder.RenderStream(Nil, @MEDIATYPE_Video, VSource, VComp, Render);

      If (hr <> NOERROR) Then

        ErrMsgException(rsCantRenderVCaptureStream);



      If ASource <> Nil Then

      Begin

        // render audio capture stream

        If (AComp <> Nil) Then

          Graph.AddFilter(AComp, ACompFilterName);

        hr := Builder.RenderStream(Nil, @MEDIATYPE_Audio, ASource, AComp, Render);

        If Failed(hr) Then

          ErrMsgException(rsCantRenderACaptureStream);

      End;

    End;



    // Rendering video preview stream

    If WantPreview And Not RenderVideoPreview(VSource) Then

      ErrMsgException(rsCantRenderPreviewStream);



    // NOTE: We do this even if we didn't ask for a preview, because rendering

    // the capture pin may have rendered the preview pin too (WDM overlay

    // devices) because they must have a preview going.  So we better always

    // put the preview window in our app, or we may get a top level window

    // appearing out of nowhere!

    If Not FindVideoWindow And (FWantPreview) Then

      ErrMsg(rsThisGraphCantPreview);



    // Render the closed captioning pin? It could be a CC or a VBI category pin,

    // depending on the capture driver

    If (FCCAvail And FCapCC) Then

    Begin

      hr := Builder.RenderStream(@PIN_CATEGORY_CC, Nil, VCap, Nil, Render);

      If (hr <> NOERROR) Then

      Begin

        hr := Builder.RenderStream(@PIN_CATEGORY_VBI, Nil, VCap, Nil, Render);

        If (hr <> NOERROR) Then

          ErrMsg(rsCantRenderCC);

      End;

      // To preview and capture VBI at the same time, we can call this twice

      If (WantPreview) Then

        Builder.RenderStream(@PIN_CATEGORY_VBI, Nil, VCap, Nil, Nil);

    End;



    // now tell it what frame rate to capture at.  Just find the format it

    // is capturing with, and leave everything alone but change the frame rate

    If UseFrameRate Then

      hr := E_FAIL

    Else

      hr := NOERROR;



    If (VStreamConf <> Nil) And UseFrameRate Then

    Begin

      // DV capture does not use a VIDEOINFOHEADER

      If VStreamConf.GetFormat(pmt) = NOERROR Then

      Begin

        Try

          If CheckGUID(pmt^.formattype, FORMAT_VideoInfo) Then

          Begin

            PVIDEOINFOHEADER(pmt^.pbFormat)^.AvgTimePerFrame := round(10000000 / FrameRate);

            hr := VStreamConf.SetFormat(pmt^);

            If hr <> NOERROR Then

              ErrMsg(rsCantSetPreviewFrameRate, hr);

          End;

        Finally

          DeleteMediaType(pmt);

        End;

      End;

    End;

    If (hr <> NOERROR) Then

      ErrMsg(rsCantSetCaptureFrameRate);



    // now ask the filtergraph to tell us when something is completed or aborted

    // (EC_COMPLETE, EC_USERABORT, EC_ERRORABORT).  This is how we will find out

    // if the disk gets full while capturing

    If (Graph.QueryInterface(IID_IMediaEventEx, MediaEvent) = NOERROR) Then

      MediaEvent.SetNotifyWindow(Handle, WM_FGNOTIFY, 0);



    // All done.

    GetAvailableDialogs;

    FGraphBuilt := true;

    Result      := true;

  Except

    TearDownGraph;

    Result := false;

  End;



End;



Function TVideoCapture.GetIsDVSource: boolean;

Var

  pmt: PAM_MEDIA_TYPE;

Begin

  Result := false;

  If (VStreamConf <> Nil) And (VStreamConf.GetFormat(pmt) = S_OK) Then

    Try

      Result := CheckGUID(pmt^.majortype, MEDIATYPE_Interleaved);

    Finally

      DeleteMediaType(pmt);

    End;

End;



// --------------------------------------------------------------------

// current capture and compressors devices

Function TVideoCapture.GetACapSourceIdx: integer;

Begin

  Result := GetIntByMoniker(AudioDevicesList, mAudio);

  If Result < 0 Then

  Begin

    BuildAudioDevicesList;

    Result := GetIntByMoniker(AudioDevicesList, mAudio);

  End;

End;



Function TVideoCapture.GetACompDeviceIdx: integer;

Begin

  Result := GetIntByMoni