{******************************************************************************}
{* Иллюстрация к книге "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;

type
  TfrmDD = class(TForm)
    ApplicationEvents1: TApplicationEvents;
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure FormKeyDown(Sender: TObject; var Key: Word;
      Shift: TShiftState);
    procedure ApplicationEvents1Idle(Sender: TObject; var Done: Boolean);
  private
    { Private declarations }
    FDD            : IDirectDraw7;
    FDDSPrimary    : IDirectDrawSurface7;
    FDDSBack       : IDirectDrawSurface7;
    FDDSImage      : IDirectDrawSurface7;
    ThisTickCount  : DWORD;
    LastTickCount  : DWORD;
    function UpdateFrame : HRESULT;
    function RestoreAll : HRESULT;
    procedure ErrorOut(hRet : HRESULT; FuncName : String);
  public
    { Public declarations }
  end;

const
  imageBmp      = '..\donut.bmp';

var
  frmDD : TfrmDD;

  wrkBitmap : TBitMap;
  rcDest : TRECT;
  TimeDelay : DWORD = 10;
  CurrentFrame : Integer = 0;

implementation

{$R *.DFM}

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 : TDDSurfaceDesc2;
begin
  wrkBitmap := TBitMap.Create;
  wrkBitmap.Height := 64;
  wrkBitmap.Width := 64;

  BitBlt(wrkBitmap.Canvas.Handle, 0, 0, 64, 64, GetDC (GetDesktopWindow), 0, 0, SRCCOPY);

  FDDSBack := nil;
  FDDSImage := nil;
  FDDSPrimary := nil;
  FDD := nil;

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

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

  FillChar (ddsd, SizeOf(ddsd), 0);
  with ddsd do begin
       dwSize := SizeOf(ddsd);
       dwFlags := DDSD_CAPS;
       ddsCaps.dwCaps := DDSCAPS_PRIMARYSURFACE;
  end;
  hRet := FDD.CreateSurface(ddsd, FDDSPrimary, nil);
  if Failed(hRet) then ErrorOut(hRet, 'Create Primary Surface');

  FDDSImage := DDLoadBitmap(FDD, imageBmp, 0, 0);
  if FDDSImage = nil then ErrorOut(hRet, 'DDLoadBitmap');

  hRet := DDSetColorKey (FDDSImage, RGB(0, 0, 0));
  if Failed (hRet) then ErrorOut(hRet, 'DDSetColorKey');

  FillChar (ddsd, SizeOf(ddsd), 0);
  with ddsd do begin
     dwSize := SizeOf(ddsd);
     dwFlags := DDSD_CAPS or DDSD_HEIGHT or DDSD_WIDTH;
     ddsCaps.dwCaps := DDSCAPS_OFFSCREENPLAIN;
     dwWidth  := 64;
     dwHeight := 64;
  end;
  hRet := FDD.CreateSurface(ddsd, FDDSBack, nil);
  if Failed(hRet) then ErrorOut(hRet, 'Create Back Surface');

  hRet := DDCopyBitmap (FDDSBack, wrkBitmap.Handle, 0, 0, 64, 64);
  if Failed(hRet) then ErrorOut(hRet, 'DDCopyBitmap');
end;

procedure TfrmDD.FormDestroy(Sender: TObject);
begin
  FDDSPrimary.BltFast(0, 0, FDDSBack, nil, DDBLTFAST_WAIT);
  if Assigned(FDD) then begin
      if Assigned(FDDSBack) then begin
         FDDSBack._Release;
         FDDSBack := nil;
      end;
      if Assigned(FDDSImage) then begin
         FDDSImage._Release;
         FDDSImage := nil;
      end;
      if Assigned(FDDSPrimary) then begin
         FDDSPrimary._Release;
         FDDSPrimary := nil;
      end;
      FDD := nil;
  end;
  wrkBitmap.Free;
end;

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

function TfrmDD.RestoreAll : HRESULT;
var
  hRet : HRESULT;
begin
  hRet := FDDSPrimary._Restore;
  if Succeeded (hRet) then begin
      hRet := FDDSBack._Restore;
      if Failed (hRet) then begin
         Result := hRet;
         Exit;
      end;
      hRet := FDDSImage._Restore;
      if Failed (hRet) then begin
         Result := hRet;
         Exit;
      end;
      hRet := DDReLoadBitmap(FDDSImage, imageBmp);
      if Failed (hRet) then ErrorOut(hRet, 'DDReLoadBitmap');
      Result := DD_OK;
  end else Result := hRet;
end;

function TfrmDD.UpdateFrame : HRESULT;
var
  rcRect : TRECT;
  hRet : HRESULT;
begin
  ThisTickCount := GetTickCount;
  if ThisTickCount - LastTickCount > TimeDelay then begin
     CurrentFrame := (CurrentFrame + 1) mod 61;
    
     SetRect (rcRect,
              (CurrentFrame mod 10) shl 6,
              (CurrentFrame div 10) shl 6,
              (CurrentFrame mod 10 + 1) shl 6,
              (CurrentFrame div 10 + 1) shl 6);
     LastTickCount := GetTickCount;
     hRet := FDDSPrimary.BltFast(0, 0, FDDSBack, nil, DDBLTFAST_WAIT);
     if Failed(hRet) then begin
        Result := hRet;
        Exit
     end;
  end;

  Result := FDDSPrimary.BltFast(0, 0, FDDSImage, @rcRect, DDBLTFAST_WAIT or DDBLTFAST_SRCCOLORKEY);
end;

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

end.

