Unit_VideoPlayerTest

unit Unit_VideoPlayerTest;

interface
uses Winapi.Windows, Winapi.Messages, Winapi.DirectShow9, Winapi.ActiveX,
System.SysUtils, Vcl.Graphics;


type
  PThunk = ^TThunk;
  TThunk = packed record
    POPEDX: Byte;
    MOVEAX: Byte;
    SelfPtr: Pointer;
    PUSHEAX: Byte;
    PUSHEDX: Byte;
    JMP: Byte;
    JmpOffset: Integer;
  end;
//type
  TCallbackThunk = class(TObject)
  private
    FCallAddress: Pointer;
    FProcPtr: Pointer;
    FSavedFlag: LongWord;
    FSelfPtr: Pointer;
    function GetCallAddress: Pointer;
  public
    constructor Create(pSelf, pProc: Pointer);
    destructor Destroy; override;
    procedure Clear;
    property CallAddress: Pointer read GetCallAddress;
  end;


type
  TVideoPlayer = class(TObject, ISampleGrabberCB)
    private
      nLeft : Integer;
      nTop : Integer;
      nWidth : Integer;
      nHeight : Integer;

      hMainWindow : HWND;
      hVideoOutputWindow : HWND;
      hRootWindow : HWND;
      hVideoOutputContainerWindow : HWND;

      fBrushRootWindow : HBRUSH;


      VideoWidth, VideoHeight : Integer;
      fThunkRoot : TCallbackThunk;
      fOldRootProc : LongInt;
      fCallbackActive : Boolean;
      fFileName :  string;
      procedure SetPositionLeft(const x : Integer);
      procedure SetPositionWidth(const w : Integer);
      procedure SetPositionHeight(const h : Integer);
      procedure SetPositionTop(const y : Integer);
    public
      pGraphBuilder : IGraphBuilder;
      pCaptureGraphBuilder : ICaptureGraphBuilder2;
      pFilterGraph : IFilterGraph;
      pVideoWindow : IVideoWindow;
      pMediaControl : IMediaControl;
      pMediaPosition : IMediaPosition;
      pMediaEvent : IMediaEventEx;
      pBasicVideo : IBasicVideo;

      fAudioDecoder : IBaseFilter;
      pBasicAudio : IBasicAudio;

      fSource : IBaseFilter;
      pSource : IFileSourceFilter;
      fSplitter : IBaseFilter;
      pSampleGrabberVideo : ISampleGrabber;
      fSampleGrabberVideo : IBaseFilter;
      fVideoDecoder : IBaseFilter;
      fAudioRenderer : IBaseFilter;
      fVideoRenderer : IBaseFilter;
      constructor Create(x,y : Integer; aOwner, aMainForm : HWND);
      destructor Destroy; override;
      function PlayerRootProc(wnd:HWND; Msg : uint; Wpar:Wparam; Lpar:LPARAM):Lresult; stdcall;

      function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall;
      function _AddRef: Integer; stdcall;
      function _Release: Integer; stdcall;
      function SampleCB(SampleTime: Double; pSample: IMediaSample): HResult; stdcall;
      function BufferCB(SampleTime: Double; pBuffer: PByte; BufferLen: longint): HResult; stdcall;

      procedure Clear;
      function BuildGraph(fn : string) : HRESULT;
      function Play : HRESULT;
      procedure Redraw;
      procedure SetPlayerPositionSize(const x,y,w,h : Integer);
      property Left: Integer read nLeft write SetPositionLeft;
      property Top: Integer read nTop write SetPositionTop;
      property Width: Integer read nWidth write SetPositionWidth;
      property Height: Integer read nHeight write SetPositionHeight;
      property Screen: HWND read hVideoOutputWindow;
      property Handle: HWND read hRootWindow;
      property FileName : string read fFileName write fFileName;
      property UseCallback : Boolean read fCallbackActive write fCallbackActive;
  end;

const
  CLSID_FfdshowVideoDecoder : TGUID = '{04FE9017-F873-410E-871E-AB91661A4EF7}';
  CLSID_ffdshowAudioDecoder : TGUID = '{0F40E1E5-4F79-4988-B1A9-CC98794E6B55}';
  CLSID_DivX_DecoderFilter : TGUID = '{78766964-0000-0010-8000-00AA00389B71}';
  CLSID_DivX_H264_Decoder : TGUID = '{6F513D27-97C3-453C-87FE-B24AE50B1601}';
  CLSID_DivX_AAC_Decoder : TGUID = '{2CCC9657-58A9-41AC-AA39-451202B98FAF}';
  CLSID_XviD_VideoDecoder : TGUID = '{64697678-0000-0010-8000-00AA00389B71}';
  CLSID_MPC_VideoDecoder : TGUID = '{008BAC12-FBAF-497B-9670-BC6F6FBAE2C4}';
  CLSID_haaliMediaSplitter : TGUID = '{55DA30FC-F16B-49FC-BAA5-AE59FC65F82D}';
  CLSID_HaaliVideoRenderer : TGUID = '{760A8F35-97E7-479D-AAF5-DA9EFF95D751}';
  CLSID_AC3ParserFilter : TGUID = '{280A3020-86CF-11D1-ABE6-00A0C905F375}';
  CLSID_AC3Filter : TGUID = '{A753A1EC-973E-4718-AF8E-A3F554D45C44}';
  CLSID_ElecardMPEGDemultiplexer : TGUID = '{136DCBF5-3874-4B70-AE3E-15997D6334F7}';
  CLSID_MPEG2_Splitter : TGUID = '{3AE86B20-7BE8-11D1-ABE6-00A0C905F375}';
  CLSID_MicrosoftDTVDVDVideoDecoder : TGUID = '{212690FB-83E5-4526-8FD7-74478B7939CD}';
  CLSID_LAV_VideoDecoder : TGUID = '{EE30215D-164F-4A92-A4EB-9D4C13390F9F}';
  CLSID_LAV_AudioDecoder : TGUID = '{E8E73B6B-4CB3-44A4-BE99-4F7BCB96E491}';
  //CLSID_VideoMixingRenderer9 : TGUID = '{51B4ABF3-748F-4E3B-A276-C828330E926A}';
  CLSID_VideoMixingRenderer7 : TGUID = '{B87BEB7B-8D29-423F-AE4D-6582C10175AC}';
  CLSID_ColorSpaceConverter : TGUID = '{1643E180-90F5-11CE-97D5-00AA0055595A}';
  CLSID_HaaliMediaSplitterAR : TGUID = '{564FD788-86C9-4444-971E-CC4A243DA150}';
  CLSID_LAV_Splitter : TGUID = '{171252A0-8820-4AFE-9DF8-5C92B2D66B04}';
  CLSID_FileSourceAsync : TGUID = '{E436EBB5-524F-11CE-9F53-0020AF0BA770}';
  CLSID_WM_ASF_Reader : TGUID = '{187463A0-5BB7-11D3-ACBE-0080C75E246E}';
  CLSID_WMVideoDecoderDMO : TGUID = '{94297043-BD82-4DFD-B0DE-8177739C6D20}';
  //CLSID_MicrosoftMPEG2_Demultplexer : TGUID = '{AFB6C280-2C41-11D3-8A60-0000F81E0E4A}';
  CLSID_BandisoftMPEG1VideoDecoder : tguid = '{89C4B786-A490-4A3E-AA70-E6A8C61D3689}';
  CLSID_BandisoftMPEG1AudioDecoder : tguid = '{E2E7539A-CECF-4A6A-B187-939943ECEF05}';
  CLSID_MPC_MP4_Splitter : TGUID = '{61F47056-E400-43D3-AF1E-AB7DFFD4C4AD}';

  MEDIASUBTYPE_AVC1 : tguid = '{31435641-0000-0010-8000-00AA00389B71}';



  WM_DS_MESSAGE = WM_USER + 4;

implementation

constructor TCallbackThunk.Create(pSelf, pProc: Pointer);
begin
  FCallAddress := nil;
  FSelfPtr := pSelf;
  FProcPtr := pProc;
end;

destructor TCallbackThunk.Destroy;
begin
  Clear;
  inherited Destroy;
end;

procedure TCallbackThunk.Clear;
var
  SaveFlag: DWORD;
begin
  if @FCallAddress <> nil then begin
    VirtualProtect(PThunk(@FCallAddress), SizeOf(TThunk),
      FSavedFlag, @SaveFlag);
    VirtualFree(FCallAddress, 0, MEM_RELEASE);
    FCallAddress := nil;
    FSavedFlag := 0;
  end;
end;

function TCallbackThunk.GetCallAddress: Pointer;
begin
  if FCallAddress = nil then begin
    FCallAddress := VirtualAlloc(nil, SizeOf(TThunk), MEM_COMMIT, PAGE_READWRITE);
    with PThunk(FCallAddress)^ do begin
      POPEDX := $5A;
      MOVEAX := $B8;
      SelfPtr := FSelfPtr;
      PUSHEAX := $50;
      PUSHEDX := $52;
      JMP := $E9;
      JmpOffset := Integer(FProcPtr) - Integer(@JMP) - 5;
    end;
    if not VirtualProtect(FCallAddress, SizeOf(TThunk), PAGE_EXECUTE_READ,
       @FSavedFlag) then begin
      FCallAddress := nil;
//      raise Exception.Create('Cannot get call address');
      MessageBox(0,'','',0);
    end;
  end;
  Result := FCallAddress;
end;



function TVideoPlayer.PlayerRootProc(wnd:HWND; Msg : uint; Wpar:Wparam; Lpar:LPARAM):Lresult; stdcall;
var
  n : Integer;
  l1,l2 : LONG_PTR;
Begin
  case msg of

    WM_DS_MESSAGE:
    begin
      while pMediaEvent.GetEvent(n, L1, l2, 1) = S_OK do
      begin
        if n = EC_COMPLETE then
        begin
          pMediaPosition.put_CurrentPosition(0);
        end;
        pMediaEvent.FreeEventParams(n, l1, l2);
      end;
    end;

  else Result := callWindowProc(Pointer(fOldRootProc),wnd,msg,wpar,lpar);
  end;
End;

function TVideoPlayer.SampleCB(SampleTime: Double; pSample: IMediaSample): HRESULT;
begin
  Result := S_OK;
end;


function TVideoPlayer.BufferCB(SampleTime: Double; pBuffer: PByte; BufferLen: Integer) : HRESULT;
var
  mt : TAMMediaType;
  bmpInfo : TBitmapInfo;
  vih : TVideoInfoHeader;
  bmp : TBitmap;
  HBMP : HBITMAP;
  tmp : array of Byte;
  buffer : Pointer;
  dc : HDC;
  r : TRect;
begin
    pSampleGrabberVideo.GetConnectedMediaType(mt);
    vih := tvideoinfoheader(mt.pbFormat^);
    ZeroMemory(@bmpinfo,SizeOf(tbitmapinfo));
    CopyMemory(@bmpinfo.bmiheader,@vih.bmiheader,SizeOf(tbitmapinfoheader));
    Buffer := nil;
    hbmp := CreateDIBSection(0,BMPInfo,DIB_PAL_COLORS, BUFFER,0,0);
    if (HBMP = 0) or (HBMP = ERROR_INVALID_PARAMETER) then
    begin
//      ShowMessage('error');
      Exit;
    end;
    bmp := TBitmap.Create;
    bmp.Handle := HBMP;
    VideoWidth := bmp.Width;
    videoHeight := bmp.Height;
    SetLength(tmp,BufferLen);
    CopyMemory(buffer,pBuffer,mt.lSampleSize);

    bmp.Canvas.Pen.Width := 4;
    bmp.Canvas.Pen.Color := RGB(255,0,0);
    bmp.Canvas.LineTo(bmp.Width,bmp.Height);
    bmp.Canvas.MoveTo(0,bmp.Height);
    bmp.Canvas.LineTo(bmp.Width,0);


    GetClientRect(Screen,r);
    dc := GetDC(Screen);
    SetStretchBltMode(dc,COLORONCOLOR);
    StretchBlt(dc,0,0,r.Right,r.Bottom, bmp.Canvas.Handle,0,0, bmp.Width,bmp.Height,SRCCOPY);
    ReleaseDC(Screen,dc);


    MoFreeMediaType(@mt);
    buffer := nil;
    bmp.Free;
  Result := S_OK;
end;

function TVideoPlayer.QueryInterface(const IID: TGUID; out Obj) : Integer;
begin
  Result := 0;
end;

function TVideoPlayer._AddRef : Integer;
begin
  Result := 0;
end;

function TVideoPlayer._Release;
begin
  Result := 0;
end;

constructor TVideoPlayer.Create(x: Integer; y: Integer; aOwner: HWND; aMainForm: HWND);
begin
  inherited Create;
  nLeft := x;
  nTop := y;
  nWidth := 300;
  nHeight := 300;
  hRootWindow := CreateWindow('static','',
                                WS_CHILD or WS_VISIBLE or WS_CLIPSIBLINGS or
                                WS_CLIPCHILDREN or SS_NOTIFY or SS_BITMAP,
                                x,y,300,300,
                                aOwner,0,HInstance,nil);
  hVideoOutputContainerWindow := CreateWindow('static','',
                                WS_CHILD or WS_VISIBLE or SS_NOTIFY or
                                SS_BITMAP or WS_CLIPCHILDREN,
                                0,0,200,200,
                                hRootWindow,0,HInstance,nil);
  hVideoOutputWindow := CreateWindow('static','',
                                WS_CHILD or WS_VISIBLE or SS_NOTIFY or SS_BITMAP,
                                0,0,200,200,
                                hVideoOutputContainerWindow,0,HInstance,nil);
  fThunkRoot := TCallbackThunk.Create(Self,@TVideoPlayer.PlayerRootProc);
  fOldRootProc := SetWindowLong(hRootWindow,GWL_WNDPROC,LongInt(fThunkRoot.CallAddress));

  fBrushRootWindow := CreateSolidBrush(RGB(0,255,0));
end;

destructor TVideoPlayer.Destroy;
begin
  Clear;
  DestroyWindow(hVideoOutputWindow);
  DestroyWindow(hVideoOutputContainerWindow);
  DestroyWindow(hRootWindow);

  DeleteObject(fBrushRootWindow);

  fThunkRoot.Free;

  inherited;
end;

procedure TVideoPlayer.Clear;
begin
  if Assigned(pMediaControl) then
  pMediaControl.Stop;

  fVideoRenderer := nil;
  fVideoDecoder := nil;
  pVideoWindow := nil;
//  pVideoGrabber.SetCallback(nil,0);
  pSampleGrabberVideo := nil;
  fSampleGrabberVideo := nil;
  fAudioDecoder := nil;
  fSplitter := nil;
  pSource := nil;
  fSource := nil;
  pMediaControl := nil;
  pMediaPosition := nil;
  pGraphBuilder := nil;
  pCaptureGraphBuilder := nil;
end;

function TVideoPlayer.BuildGraph(fn: string) : HRESULT;
var
  mtv : AM_MEDIA_TYPE;
  r : TRect;
begin
  Result := CoCreateInstance(CLSID_FilterGraph, nil, CLSCTX_INPROC_SERVER ,
                           IID_IGraphBuilder, pGraphBuilder);
  Result := CoCreateInstance(CLSID_CaptureGraphBuilder2, NIL,
                          CLSCTX_INPROC_SERVER, IID_ICaptureGraphBuilder2,
                         pCaptureGraphBuilder);
  pCaptureGraphBuilder.SetFiltergraph(pGraphBuilder);

  Result := pGraphBuilder.AddSourceFilter(StringToOleStr(fn),'source', fSource);



  Result := coCreateInstance(CLSID_FfdshowVideoDecoder, nil,
                               CLSCTX_INPROC_SERVER,
                               IID_IBaseFilter, FVIDEODECODER);
  pGraphBuilder.AddFilter(fVideoDecoder, 'ffdshow video');


  Result := coCreateInstance(CLSID_SampleGrabber, nil,
                               CLSCTX_INPROC_SERVER,
                               IID_ISampleGrabber, pSampleGrabberVideo);

  ZeroMemory(@mtv, SizeOf(mtv));
  mtv.majortype := MEDIATYPE_Video;
  mtv.subtype := MEDIASUBTYPE_RGB32;
  mtv.formattype := FORMAT_VideoInfo;
  pSampleGrabberVideo.SetMediaType(mtv);
  pSampleGrabberVideo.SetOneShot(False);
  pSampleGrabberVideo.SetBufferSamples(True);

  if UseCallback then
  pSampleGrabberVideo.setCallback(Self,1);

  pSampleGrabberVideo.QueryInterface(IID_IBaseFilter, fSAMPLEGRABBERVIDEO);
  pGraphBuilder.AddFilter(fSampleGrabberVideo, 'video grabber');


  if UseCallback then
  begin
    Result := coCreateInstance(CLSID_NullRenderer, nil,
                               CLSCTX_INPROC_SERVER,
                               IID_IBaseFilter, fVideoRenderer);
    pGraphBuilder.AddFilter(fVideoRenderer, 'null video renderer');

  end else
  begin
    Result := coCreateInstance(CLSID_VideoRendererDefault, nil,
                               CLSCTX_INPROC_SERVER,
                               IID_IBaseFilter, fVideoRenderer);
    pGraphBuilder.AddFilter(fVideoRenderer, 'video renderer');

  end;

  Result := pCaptureGraphBuilder.RenderStream(nil,@mediatype_video,
                             fSource, fVideoDecoder,fSampleGrabberVideo);
  Result := pCaptureGraphBuilder.RenderStream(nil,@mediatype_video,
                             fSampleGrabberVideo, nil, fVideoRenderer);

  if Result = S_OK then
  begin
    pGraphBuilder.QueryInterface(IID_IVideoWindow, pvideowindow);
    pVideoWindow.put_Owner(Screen);
    pVideoWindow.put_WindowStyle(WS_CHILD or WS_CLIPSIBLINGS);
    GetClientRect(Screen,r);
    pVideoWindow.SetWindowPosition(0,0, r.Right,r.Bottom);
    pGraphBuilder.QueryInterface(IID_IMediaPosition,pmediaposition);
    pMediaPosition.put_CurrentPosition(35);
    pGraphBuilder.QueryInterface(IID_IMediaControl,pMediaControl);
    pMediaControl.Run;
  end else
  Clear;

end;

function TVideoPlayer.Play : HRESULT;
begin
  Result := S_OK;
  if Assigned(pMediaControl) then
  begin
    Result := pMediaControl.Run;
  end else
  begin
    if (FileName<>'') and (FileExists(FileName)) then
    begin
      Clear;
      if BuildGraph(FileName) = S_OK then
      Result := pMediaControl.Run;
    end;
  end;
end;

procedure TVideoPlayer.Redraw;
var
  r : TRect;
  dc : HDC;
begin
  GetClientRect(hRootWindow,r);
  dc := GetDC(hRootWindow);
  FillRect(dc,r,fBrushRootWindow);
  ReleaseDC(hRootWindow,dc);
end;

procedure TVideoPlayer.SetPlayerPositionSize(const x,y,w,h : Integer);
begin
  nLeft := x;
  nTop := y;
  nWidth := w;
  nHeight := h;
  SetWindowPos(hRootWindow,0,x,y,w,h, SWP_NOZORDER or SWP_NOACTIVATE);
  Redraw;
end;

procedure TVideoPlayer.SetPositionLeft(const x : Integer);
begin
  if nLeft <> x then
  begin
    nLeft := x;
    SetPlayerPositionSize(x,nTop,nWidth,nHeight);
  end;
end;

procedure TVideoPlayer.SetPositionTop(const y : Integer);
begin
  if nTop <> y then
  begin
    nTop := y;
    SetPlayerPositionSize(nLeft,nTop,nWidth,nHeight);
  end;
end;

procedure TVideoPlayer.SetPositionWidth(const w : Integer);
begin
  if nWidth <> w then
  begin
    nWidth := w;
    SetPlayerPositionSize(nLeft,nTop,W,nHeight);
  end;
end;

procedure TVideoPlayer.SetPositionHeight(const h : Integer);
begin
  if nHeight <> h then
  begin
    nHeight := h;
    SetPlayerPositionSize(nLeft,nTop,nWidth,H);
  end;
end;

end.