unit main;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs;

type
  TForm1 = class(TForm)
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
    procedure Idle( Sender: TObject; var Done: Boolean );
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

uses
  DirectDraw;

var
  lpDD7:            IDirectDraw7        = nil;
  lpPrimarySurface: IDirectDrawSurface7 = nil;
  lpBackBuffer:     IDirectDrawSurface7 = nil;

  lpWallpaper:      IDirectDrawSurface7  = nil;
  lpSprite:         IDirectDrawSurface7  = nil;




//------------------------------------------------------------------------------
// Имя:      InitDirectDraw()
// Описание: Производит инициализацию объектов DirectDraw в программе
//------------------------------------------------------------------------------
function InitDirectDraw( hWnd: HWND ): Boolean;
var
  ddsd2: TDDSURFACEDESC2;
  ddsc2: TDDSCAPS2;
begin
  Result := FALSE;

  if FAILED( DirectDrawCreateEx( nil, lpDD7, IID_IDirectDraw7, nil ) ) then
     Exit;

  lpDD7._AddRef();

  if FAILED( lpDD7.SetCooperativeLevel( hWnd, DDSCL_ALLOWREBOOT or
                                            DDSCL_EXCLUSIVE or
                                            DDSCL_FULLSCREEN ) ) then
     Exit;

  if FAILED( lpDD7.SetDisplayMode( 640, 480, 16, 0, 0 ) ) then
     Exit;

  // Подготавливаем структуру DDSURFACEDESC
  ZeroMemory( @ddsd2, SizeOf( TDDSURFACEDESC2 ) );
  ddsd2.dwSize := SizeOf( TDDSURFACEDESC2 );

  ddsd2.dwFlags := DDSD_CAPS or DDSD_BACKBUFFERCOUNT;
  ddsd2.ddsCaps.dwCaps := DDSCAPS_PRIMARYSURFACE or
                             DDSCAPS_FLIP or
                             DDSCAPS_COMPLEX;
  ddsd2.dwBackBufferCount := 1;

  // Создаём первичную поверхность (фактически постоянно видимую на экране)
  if FAILED( lpDD7.CreateSurface( ddsd2, lpPrimarySurface, nil ) ) then
     Exit;

  lpPrimarySurface._AddRef();

  // Подготавливаем структуру DDSCAPS
  ZeroMemory( @ddsc2, SizeOf( TDDSCAPS2 ) );
  ddsc2.dwCaps := DDSCAPS_BACKBUFFER;

  if FAILED( lpPrimarySurface.GetAttachedSurface( ddsc2, lpBackBuffer ) ) then
     Exit;

  lpBackBuffer._AddRef();

  Result := TRUE;
end;




//------------------------------------------------------------------------------
// Имя:      ReleaseDirectDraw()
// Описание: Удаляет из памяти объекты DirectDraw
//------------------------------------------------------------------------------
procedure ReleaseDirectDraw();
begin
  // Удаляем сперва дополнительный буфер
  if lpBackBuffer <> nil then
  begin
    lpBackBuffer._Release();
    lpBackBuffer := nil;
  end;

  // Теперь можно удалить первичную поверхность
  if lpPrimarySurface <> nil then
  begin
    lpPrimarySurface._Release();
    lpPrimarySurface := nil;
  end;

  // Наконец, последним удаляем главный объект DirectDraw
  if lpDD7 <> nil then
  begin
    lpDD7.RestoreDisplayMode(); // Восстанавливаем видеорежим
    lpDD7._Release();
    lpDD7 := nil;
  end;
end;




//------------------------------------------------------------------------------
// Имя:      CreateSurface()
// Описание: Создаёт поверхность DirectDraw нужных размеров
//------------------------------------------------------------------------------
function CreateSurface( var lpSurface: IDirectDrawSurface7; nWidth,
                        nHeight: Integer ): Boolean;
var
  ddsd2: TDDSURFACEDESC2;
begin
  Result := FALSE;

  // Если поверхность существует, то удаляем
  if lpSurface <> nil then
  begin
    lpSurface._Release;
    lpSurface := nil;
  end;

  // Подготавливаем структуру DDSURFACEDESC2
  ZeroMemory( @ddsd2, SizeOf( TDDSURFACEDESC2 ) );
  with ddsd2 do
  begin
    dwSize         := SizeOf( TDDSURFACEDESC2 );
    dwFlags        := DDSD_CAPS or DDSD_WIDTH or DDSD_HEIGHT;
    ddsCaps.dwCaps := DDSCAPS_OFFSCREENPLAIN;
    dwWidth        := nWidth;
    dwHeight       := nHeight;
  end;

  // Создаём поверхность
  if FAILED( lpDD7.CreateSurface( ddsd2, lpSurface, nil ) ) then
     Exit;

  lpSurface._AddRef;

  Result := TRUE;
end;




//------------------------------------------------------------------------------
// Имя:      CopyImage()
// Описание: Копирует изображение на поверхность DirectDraw
//------------------------------------------------------------------------------
function CopyImage( var lpSurface: IDirectDrawSurface7; hImage: HBITMAP
  ): Boolean;
var
  destDC,          // Поверхность-приёмник
  srcDC:  HDC;     // Поверхность-источник
  bm:     BITMAP;  // BITMAP из windows.pas
  hObj:   HGDIOBJ; // Объект GDI
begin
  Result := FALSE;

  // Создаём контекст памяти, совместимый с Рабочим столом
  srcDC := CreateCompatibleDC( 0 );

  // Если контекст не получен - обрабатываем ошибку
  if srcDC = 0 then Exit;

  // Выбираем в контекст растр
  hObj := SelectObject( srcDC, hImage );
  if ( hObj = 0 ) or ( hObj = GDI_ERROR ) then
     Exit;

  // Получаем размеры растра, данные заполняют структуру BITMAP
  if GetObject( hImage, SizeOf( bm ), @bm ) = 0 then
     Exit;

  // Пересоздаём поверхность с размерами растра
  if not CreateSurface( lpSurface, bm.bmWidth, bm.bmHeight ) then
     Exit;

  // Создаём GDI-совместимый контекст для поверхности
  if SUCCEEDED( lpSurface.GetDC( destDC ) ) then
  begin
    // BtlBlt-им в контексте (а фактически на поверхности DirectDraw)
    BitBlt( destDC, 0, 0, bm.bmWidth, bm.bmHeight, srcDC, 0, 0, SRCCOPY );
    lpSurface.ReleaseDC( destDC );
  end
  else Exit;

  // В конце операции удаляем объекты GDI
  DeleteObject( hObj );
  DeleteDC( srcDC );

  Result := TRUE;
end;




//------------------------------------------------------------------------------
// Имя:      ()
// Описание:
//------------------------------------------------------------------------------
procedure TForm1.Idle( Sender: TObject; var Done: Boolean );
var
  rRect: TRect;
begin
  SetRect( rRect, 0, 0, 640, 480 );
  lpBackBuffer.BltFast(0, 0, lpWallpaper, @rRect, DDBLTFAST_WAIT );

  SetRect( rRect, 0, 0, 256, 256 );
  lpBackBuffer.BltFast(0, 0, lpSprite, @rRect, DDBLTFAST_WAIT );

  lpPrimarySurface.Flip(nil, DDFLIP_WAIT);

  Done := FALSE;
end;

//------------------------------------------------------------------------------
// Имя:      ()
// Описание:
//------------------------------------------------------------------------------
procedure TForm1.FormCreate(Sender: TObject);
var
  hImage: HBITMAP;
begin
  if not InitDirectDraw( Form1.Handle ) then
  begin
    MessageBox( Form1.Handle, 'Ошибка при инициализации DirectDraw!' + #13 +
                'Возможно, разрешение 640x480x16 не поддерживается адаптером.',
                'Ошибка!', MB_ICONHAND );
    Form1.Close();
  end;

  hImage := LoadImage( 0, 'Wallpaper.bmp', IMAGE_BITMAP, 0, 0, LR_LOADFROMFILE or
                                                               LR_CREATEDIBSECTION );

  if hImage = 0 then Form1.Close();

  if not CopyImage( lpWallpaper, hImage ) then Form1.Close();

  hImage := LoadImage( 0, 'sprite.bmp', IMAGE_BITMAP, 0, 0, LR_LOADFROMFILE or
                                                            LR_CREATEDIBSECTION );
  if not CopyImage( lpSprite, hImage ) then Form1.Close();

  Application.OnIdle := Idle;
end;




//------------------------------------------------------------------------------
// Имя:      ()
// Описание:
//------------------------------------------------------------------------------
procedure TForm1.FormDestroy(Sender: TObject);
begin
  ReleaseDirectDraw();
end;

end.