{******************************************************************************}
{* Иллюстрация к книге "DirectX. Графика в проектах Delphi".                  *}
{* Издательство BHV. www.bhv.ru                                               *}
{* Краснов М.В. softgl@chat.ru                                                *}
{******************************************************************************}
unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  AppEvnts, ExtCtrls,
  DirectDraw, DDUtil, DirectShow, ComObj;

type
  TfrmDD = class(TForm)
    ApplicationEvents1: TApplicationEvents;
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure ApplicationEvents1Deactivate(Sender: TObject);
    procedure FormKeyDown(Sender: TObject; var Key: Word;
      Shift: TShiftState);
    procedure ApplicationEvents1Restore(Sender: TObject);
    procedure FormActivate(Sender: TObject);
    procedure ApplicationEvents1Idle(Sender: TObject; var Done: Boolean);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
  private
    { Private declarations }
    FDD            : IDirectDraw;
    FDDSPrimary    : IDirectDrawSurface;
    FDDSBackGround : IDirectDrawSurface;
    FDDSBack       : IDirectDrawSurface;
    FDDSImage      : IDirectDrawSurface;
    FActive        : BOOL;
    function UpdateFrame : HRESULT;
    function RestoreAll : HRESULT;
    function FlipPages : HRESULT;
    procedure ErrorOut(hRet : HRESULT; FuncName : String);
    procedure PlayMedia(const FileName : WideString);
  public
    { Public declarations }
  protected
    procedure FormSetCursor(var aMsg : TMessage); message WM_SETCURSOR;
  end;

const
  ScreenWidth    = 640;
  ScreenHeight   = 480;
  ScreenBitDepth = 16;
  groundBmp      = '..\fon.bmp';
  AVIName        = '..\clocktxt.avi';
  AVIWidth       = 321;
  AVIHeight      = 321;

var
  frmDD : TfrmDD;

implementation

{$R *.DFM}

var
  AMStream : IAMMultiMediaStream;
  PrimaryVidStream : IMediaStream;
  Sample : IDirectDrawStreamSample;
  Bitmap : TBitmap;

procedure TfrmDD.ErrorOut(hRet : HRESULT; FuncName : String);
var
  t : TextFile;
begin
  AssignFile (t, 'Debug.txt');
  Rewrite (t);
  WriteLn (t, FuncName + ': ' + DDErrorString (hRet));
  CloseFile (t);
  Destroy;
end;

procedure TfrmDD.FormCreate(Sender: TObject);
var
  hRet : HRESULT;
  ddsd : TDDSurfaceDesc;
  ddscaps : TDDSCaps;
  DC : HDC;
begin
  FDDSImage := nil;
  FDDSBack := nil;
  FDDSBackGround := nil;
  FDDSPrimary := nil;
  FDD := nil;

  hRet := DirectDrawCreate (nil, FDD, nil);
  if Failed(hRet) then ErrorOut(hRet, 'DirectDrawCreate');

  hRet := FDD.SetCooperativeLevel(Handle, DDSCL_FULLSCREEN or DDSCL_EXCLUSIVE);
  if Failed(hRet) then ErrorOut(hRet, 'SetCooperativeLevel');

  hRet := FDD.SetDisplayMode (ScreenWidth, ScreenHeight, ScreenBitDepth);
  if Failed(hRet) then ErrorOut(hRet, 'SetDisplayMode');

  ZeroMemory (@ddsd, SizeOf(ddsd));
  with ddsd do begin
       dwSize := SizeOf(ddsd);
       dwFlags := DDSD_CAPS or DDSD_BACKBUFFERCOUNT;
       ddsCaps.dwCaps := DDSCAPS_PRIMARYSURFACE or DDSCAPS_FLIP or DDSCAPS_COMPLEX;
       dwBackBufferCount := 1;
  end;
  hRet := FDD.CreateSurface(ddsd, FDDSPrimary, nil);
  if Failed(hRet) then ErrorOut(hRet, 'Create Primary Surface');

  Bitmap := TBitmap.Create;
  Bitmap.LoadFromFile (groundBmp);

  ZeroMemory (@ddsd, SizeOf(ddsd));
  with ddsd do begin
       dwSize := SizeOf(ddsd);
       dwFlags := DDSD_CAPS or DDSD_HEIGHT or DDSD_WIDTH;
       ddsCaps.dwCaps := DDSCAPS_OFFSCREENPLAIN;
       dwWidth  := Bitmap.Width;
       dwHeight := Bitmap.Height;
  end;
  hRet := FDD.CreateSurface(ddsd, FDDSBackGround, nil);
  if Failed(hRet) then ErrorOut(hRet, 'Create BackGround Surface');

  if FDDSBackGround.GetDC(DC) = DD_OK then begin
     BitBlt (DC, 0, 0, Bitmap.Width, Bitmap.Height, Bitmap.Canvas.Handle,
             0, 0, SRCCOPY);
     FDDSBackGround.ReleaseDC(DC);
  end;

  ZeroMemory (@ddsd, SizeOf(ddsd));
  with ddsd do begin
       dwSize := SizeOf(ddsd);
       dwFlags := DDSD_CAPS or DDSD_HEIGHT or DDSD_WIDTH;
       ddsCaps.dwCaps := DDSCAPS_OFFSCREENPLAIN;
       dwWidth  := AVIWidth;
       dwHeight := AVIHeight;
  end;
  hRet := FDD.CreateSurface(ddsd, FDDSImage, nil);
  if Failed(hRet) then ErrorOut(hRet, 'Create Second Surface');

  ZeroMemory (@ddscaps, SizeOf(ddscaps));
  ddscaps.dwCaps := DDSCAPS_BACKBUFFER;
  hRet := FDDSPrimary.GetAttachedSurface(ddscaps, FDDSBack);
  if Failed(hRet) then ErrorOut(hRet, 'GetAttachedSurface');

  PlayMedia(AVIName);
end;

procedure TfrmDD.FormDestroy(Sender: TObject);
begin
  (AMStream as IMultiMediaStream).SetState(STREAMSTATE_STOP);
  Bitmap.Free;
  if Assigned(FDD) then begin
      if Assigned(FDDSBackGround) then FDDSBackGround := nil;
      if Assigned(FDDSBack) then FDDSBack := nil;
      if Assigned(FDDSImage) then FDDSImage := nil;
      if Assigned(FDDSPrimary) then FDDSPrimary := nil;
      FDD := nil;
  end;
end;

procedure TfrmDD.ApplicationEvents1Deactivate(Sender: TObject);
begin
  FActive := False;
  (AMStream as IMultiMediaStream).SetState(STREAMSTATE_STOP);
  Application.Minimize;
end;

procedure TfrmDD.FormKeyDown(Sender: TObject; var Key: Word;
  Shift: TShiftState);
begin
  if (Key = VK_ESCAPE) or (Key = VK_F12) then Close;
end;

procedure TfrmDD.FormSetCursor(var aMsg : TMessage);
begin
  SetCursor(0);
end;

function TfrmDD.RestoreAll : HRESULT;
var
  hRet : HRESULT;
  DC : HDC;
begin
  hRet := FDDSPrimary._Restore;
  if Succeeded (hRet) then begin
      hRet := FDDSBackGround._Restore;
      if Failed (hRet) then begin
         Result := hRet;
         Exit;
      end;
      hRet := FDDSBackGround.GetDC(DC);
      if Failed (hRet) then begin
         Result := hRet;
         Exit;
      end;
      BitBlt (DC, 0, 0, Bitmap.Width, Bitmap.Height, Bitmap.Canvas.Handle,
              0, 0, SRCCOPY);
      hRet := FDDSBackGround.ReleaseDC(DC);
      if Failed (hRet) then begin
         Result := hRet;
         Exit;
      end;
      Result := FDDSImage._Restore;
  end else Result := hRet;
end;

procedure TfrmDD.ApplicationEvents1Restore(Sender: TObject);
begin
  WindowState := wsMaximized;
  (AMStream as IMultiMediaStream).SetState (STREAMSTATE_RUN);
  FActive := True;
end;

procedure TfrmDD.FormActivate(Sender: TObject);
begin
  FActive := True;
end;

procedure TfrmDD.ApplicationEvents1Idle(Sender: TObject;
  var Done: Boolean);
begin
 if FActive then
     if Succeeded (UpdateFrame) then FlipPages;
  Done := False;
end;

function TfrmDD.UpdateFrame : HRESULT;
var
  hRet : HRESULT;
begin
  hRet := FDDSBack.BltFast (0, 0, FDDSBackGround, nil, DDBLTFAST_WAIT);
  if hRet = DDERR_SURFACELOST then begin
     hRet := RestoreAll;
     if Failed (hRet) then begin
        Result := hRet;
        Exit;
     end;
  end;

  if Sample.Update(0, 0, nil, 0) <> S_OK then (AMStream as IMultiMediaStream).Seek (0);

  hRet := FDDSBack.BltFast (0, 0, FDDSImage, nil, DDBLTFAST_WAIT);
  if hRet = DDERR_SURFACELOST then begin
     hRet := RestoreAll;
     if Failed (hRet) then begin
        Result := hRet;
        Exit;
     end;
  end;

  Result := DD_OK;
end;

function TfrmDD.FlipPages : HRESULT;
begin
  Result := FDDSPrimary.Flip(nil, DDFLIP_WAIT);
  if Result = DDERR_SURFACELOST then Result := RestoreAll;
end;

procedure TfrmDD.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  Hide
end;

procedure TfrmDD.PlayMedia(const FileName : WideString);
var
   hRet : HRESULT;
begin
    AMStream := IAMMultiMediaStream(CreateComObject(CLSID_AMMultiMediaStream));

    hRet := AMStream.Initialize(STREAMTYPE_READ, 0, nil);
    if Failed (hRet) then ErrorOut (hRet, 'Stream Initialize');

    hRet := AMStream.AddMediaStream(FDD, MSPID_PrimaryVideo,
      0, IMediaStream(nil^));
    if Failed (hRet) then ErrorOut (hRet, 'Add Video Stream');

    hRet := AMStream.OpenFile(PWideChar(FileName),0);
    if Failed (hRet) then ErrorOut (hRet, 'Open AVI File');

    hRet := (AMStream as IMultiMediaStream).GetMediaStream(MSPID_PrimaryVideo, PrimaryVidStream);
    if Failed (hRet) then ErrorOut (hRet, 'GetMediaStream');

    hRet := (PrimaryVidStream as IDirectDrawMediaStream).CreateSample(FDDSImage, TRect(nil^), 0, Sample);
    if Failed (hRet) then ErrorOut (hRet, 'CreateSample');

    hRet := (AMStream as IMultiMediaStream).SetState(STREAMSTATE_RUN);
    if Failed (hRet) then ErrorOut (hRet, 'SetState');
end;

end.


