{******************************************************************************}
{* Иллюстрация к книге "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 ApplicationEvents1Deactivate(Sender: TObject);
    procedure FormKeyDown(Sender: TObject; var Key: Word;
      Shift: TShiftState);
    procedure ApplicationEvents1Restore(Sender: TObject);
    procedure FormMouseMove(Sender: TObject; Shift: TShiftState; X,
      Y: Integer);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
  private
    { Private declarations }
    FDD            : IDirectDraw7;
    FDDSPrimary    : IDirectDrawSurface7;
    FDDSBack       : IDirectDrawSurface7;
    FDDSBackGround : IDirectDrawSurface7;
    FDDSZoom       : IDirectDrawSurface7;
    FDDSDouble     : IDirectDrawSurface7;
    function UpdateFrame : HRESULT;
    function RestoreAll : HRESULT;
    function FlipPages : HRESULT;
    procedure ErrorOut(hRet : HRESULT; FuncName : String);
  public
    { Public declarations }
  protected
    procedure FormSetCursor(var aMsg : TMessage); message WM_SETCURSOR;
  end;

const
  ScreenWidth    = 640;
  ScreenHeight   = 480;
  ScreenBitDepth = 16;
  GroundBmp      = '..\colorful_universe.bmp';
  ZoomBmp        = '..\zoom.bmp';

var
  frmDD : TfrmDD;
  mouseX : Integer = 300;
  mouseY : Integer = 300;

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;
  ddscaps : TDDSCaps2;
begin
  FDDSBackGround := nil;
  FDDSZoom := nil;
  FDDSDouble := nil;
  FDDSBack := nil;
  FDDSPrimary := nil;
  FDD := nil;

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

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

  hRet := FDD.SetDisplayMode (ScreenWidth, ScreenHeight, ScreenBitDepth, 0, 0);
  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');

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

  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 := 100;
     dwHeight := 100;
  end;
  hRet := FDD.CreateSurface(ddsd, FDDSZoom, nil);
  if Failed(hRet) then ErrorOut(hRet, 'Create Zoom Surface');

  FDDSDouble := DDLoadBitmap(FDD, ZoomBmp, 0, 0);
  if FDDSDouble = nil then ErrorOut(hRet, 'DDLoadBitmap');

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

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

  FDDSBackGround := DDLoadBitmap(FDD, GroundBmp, 0, 0);
  if FDDSBackGround = nil then ErrorOut(DD_FALSE, 'DDLoadBitmap');
end;

procedure TfrmDD.FormDestroy(Sender: TObject);
begin
  if Assigned(FDD) then begin
      if Assigned(FDDSZoom) then FDDSZoom := nil;
      if Assigned(FDDSDouble) then FDDSDouble := nil;
      if Assigned(FDDSBackGround) then FDDSBackGround := nil;
      if Assigned(FDDSBack) then FDDSBack := nil;
      if Assigned(FDDSPrimary) then FDDSPrimary := nil;
      FDD := nil;
  end;
end;

procedure TfrmDD.ApplicationEvents1Deactivate(Sender: TObject);
begin
  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;
begin
  hRet := FDDSPrimary._Restore;
  if Succeeded (hRet) then begin
      hRet := FDDSZoom._Restore;
      if Failed (hRet) then begin
         Result := hRet;
         Exit;
      end;
      hRet := FDDSDouble._Restore;
      if Failed (hRet) then begin
         Result := hRet;
         Exit;
      end;
      hRet := DDReLoadBitmap(FDDSDouble, ZoomBmp);
      if Failed (hRet) then begin
         Result := hRet;
         Exit;
      end;
      hRet := FDDSBackGround._Restore;
      if Failed (hRet) then begin
         Result := HRet;
         Exit;
      end;
      Result := DDReLoadBitmap(FDDSBackGround, GroundBmp);
  end else Result := hRet;
end;

procedure TfrmDD.ApplicationEvents1Restore(Sender: TObject);
begin
  WindowState := wsMaximized;
end;

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

  SetRect (wrkRect, mouseX + 25, mouseY + 25, mouseX + 75, mouseY + 75);
  hRet := FDDSZoom.Blt (nil, FDDSBackGround, @wrkRect, DDBLT_WAIT, nil);
  if Failed (hRet) then begin
     Result := hRet;
     Exit;
  end;

  hRet := FDDSZoom.BltFast (0, 0, FDDSDouble, nil, DDBLTFAST_WAIT or DDBLTFAST_SRCCOLORKEY);
  if Failed (hRet) then begin
     Result := hRet;
     Exit;
  end;

  hRet := FDDSBack.BltFast (mouseX, mouseY, FDDSZoom, nil,
                    DDBLTFAST_WAIT or DDBLTFAST_SRCCOLORKEY);
  if Failed (hRet) then begin
     Result := hRet;
     Exit;
  end;

  Result := FlipPages;
end;

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

procedure TfrmDD.FormMouseMove(Sender: TObject; Shift: TShiftState; X,
  Y: Integer);
begin
  if X <= ScreenWidth - 100
     then mouseX := X
     else mouseX := ScreenWidth - 100;
  if Y <= ScreenHeight - 100
     then mouseY := Y
     else mouseY := ScreenHeight - 100;
  if Failed (UpdateFrame) then RestoreAll;
end;

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

end.


