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

interface

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

type
  TfrmDD = class(TForm)
    ApplicationEvents1: TApplicationEvents;
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure FormPaint(Sender: TObject);
    procedure ApplicationEvents1Deactivate(Sender: TObject);
    procedure FormKeyDown(Sender: TObject; var Key: Word;
      Shift: TShiftState);
    procedure ApplicationEvents1Restore(Sender: TObject);
  private
    { Private declarations }
    FDD : IDirectDraw7;
    FDDSPrimary    : IDirectDrawSurface7;
    FDDSImage      : IDirectDrawSurface7;
    function RestoreAll : HRESULT;
    procedure ErrorOut(hRet : HRESULT; FuncName : string);
  public
    { Public declarations }
  end;

var
  frmDD: TfrmDD;

implementation

{$R *.DFM}

procedure TfrmDD.ErrorOut(hRet : HRESULT; FuncName : string);
begin
  MessageBox(0, PChar(FuncName + ': ' + #13 + DDErrorString(hRet)),
             PChar(Caption), MB_OK or MB_ICONSTOP);
end;

procedure TfrmDD.FormCreate(Sender: TObject);
var
  hRet : HRESULT;
  ddsd : TDDSurfaceDesc2;
  wrkBitmap : TBitmap;
begin
  FDDSImage := nil;
  FDDSPrimary := nil;
  FDD := nil;

  hRet := DirectDrawCreateEx (nil, FDD, IDirectDraw7, nil);
  if hRet <> DD_OK then begin
      ErrorOut(hRet, 'DirectDrawCreateEx');
      Exit;
  end;

  hRet := FDD.SetCooperativeLevel(Handle, DDSCL_FULLSCREEN or DDSCL_EXCLUSIVE);
  if hRet <> DD_OK then begin
     ErrorOut(hRet, 'SetCooperativeLevel');
     Exit;
  end;

  hRet := FDD.SetDisplayMode (640, 480, 16, 0, 0);
  if hRet <> DD_OK then begin
     ErrorOut(hRet, 'SetDisplayMode');
     Exit;
  end;

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

  wrkBitmap := TBitmap.Create;
  wrkBitmap.LoadFromFile ('..\rainbow.bmp');

  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  := wrkBitmap.Width;
     dwHeight := wrkBitmap.Height;
  end;
  hRet := FDD.CreateSurface(ddsd, FDDSImage, nil);
  if hRet <> DD_OK then begin
     ErrorOut(hRet, 'Create Image Surface');
     Exit;
  end;

  hRet := DDCopyBitmap (FDDSImage, wrkBitmap.Handle, 0, 0, wrkBitmap.Width, wrkBitmap.Height);
  if hRet <> DD_OK then begin
     ErrorOut(hRet, 'DDCopyBitmap');
     Exit;
  end;

  wrkBitmap.Free;
end;

procedure TfrmDD.FormDestroy(Sender: TObject);
begin
  if Assigned(FDD) then begin
      if Assigned(FDDSImage) then FDDSImage := nil;
      if Assigned(FDDSPrimary) then FDDSPrimary := nil;
      FDD := nil;
  end;
end;

procedure TfrmDD.FormPaint(Sender: TObject);
var
  hRet : HRESULT;
begin
  while True do begin
    hRet := FDDSPrimary.Blt (nil, FDDSImage, nil,
                             DDBLT_WAIT, nil);
    if hRet = DDERR_SURFACELOST then begin
       if Failed (RestoreAll) then Exit;
    end
    else Break;
  end;
end;

procedure TfrmDD.ApplicationEvents1Deactivate(Sender: TObject);
begin
  Application.Minimize;
end;

procedure TfrmDD.FormKeyDown(Sender: TObject; var Key: Word;
  Shift: TShiftState);
begin
  case Key of
     VK_ESCAPE, VK_F12 : begin
                         Close;
                         Exit;
                         end;
  end;
end;

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

function TfrmDD.RestoreAll : HRESULT;
begin
  Result := DD_FALSE;
  if Succeeded (FDDSPrimary._Restore) then begin
      if Failed (FDDSImage._Restore) then Exit;
      Result := DD_OK;
  end;
end;

end.

