//------------------------------------------------------------------
//    Файл:     pscreen.pas
//    Описание: Функция для сохранения образа экрана в bmp-файле
//------------------------------------------------------------------
unit pscreen;

interface

uses
  windows,
  directdraw;




//------------------------------------------------------------------
// прототипы функций
//------------------------------------------------------------------
function SaveScreenToBitMap( szFileName: pchar; const pSurface: IDirectDrawSurface7 ): boolean;

implementation




//------------------------------------------------------------------
// сохраняет растр с поверхности DirectDraw в файле формата *.bmp
//------------------------------------------------------------------
function SaveScreenToBitMap( szFileName: pchar; const pSurface: IDirectDrawSurface7 ): boolean;
var
  hFile:          THandle;     // дескриптор создаваемого файла
  dwBytesWritten: DWORD;       // количество записанных байт (переменная нужна обязательно)

  fh:        BITMAPFILEHEADER; // заголовок bmp-файла
  bi:        BITMAPINFOHEADER; // заголовок с информацией о формате файла

  pPixels:   pbyte;            // массив с пикселями
  dwPointer: DWORD;            // указатель на позицию в массиве

  ddsd2:     TDDSURFACEDESC2;  // служит для получения информации о формате поверхности

  dwWidth:   DWORD;            // ширина,
  dwHeight:  DWORD;            // высота и
  dwBPP:     DWORD;            // глубина цвета поверхности DirectDraw

  pixel:     DWORD;            // цвет считанного пикселя
  r, g, b:   byte;             // цветовые веса составляющих пикселя

  i, j:      integer;          // переменные используются в цикле
begin
  result := false;

  // проверяем имя файла и существование поверхности
  if( szFileName = nil ) or ( pSurface = nil ) then
      exit;

  // создаём файл с заданным именем, в него будет производиться запись
  hFile := CreateFile( szFileName, GENERIC_WRITE, FILE_SHARE_READ, nil, CREATE_ALWAYS, 0, 0 );
  if hFile = INVALID_HANDLE_VALUE then
  begin
    CloseHandle( hFile );
    exit;
  end;

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

  // получаем формат поверхности
  pSurface.GetSurfaceDesc( ddsd2 );
  dwWidth  := ddsd2.dwWidth;
  dwHeight := ddsd2.dwHeight;
  dwBPP    := ddsd2.ddpfPixelFormat.dwRGBBitCount;

  // подготавливаем структуру TDDSURFACEDESC2 ещё раз
  ZeroMemory( @ddsd2, sizeof( TDDSURFACEDESC2 ) );
  ddsd2.dwSize := sizeof( TDDSURFACEDESC2 );

  // блокируем поверхность DirectDraw
  if( FAILED( pSurface.Lock( nil, ddsd2, DDLOCK_WAIT, 0 ) ) ) then
      exit;

  //------------------------------

  pPixels := pbyte(GlobalAllocPtr( GMEM_MOVEABLE, dwWidth * dwHeight * 3 ));
  if pPixels = nil then
     exit;

  dwPointer := 0;

  // начинаем записывать побайтно в буфер значения цветов пикселей поверхности
  // учитываем то, что растр в файле должен быть перевёрнутым
  for j := dwHeight - 1 downto 0 do
  for i := 0 to dwWidth - 1 do
  begin
  
    case dwBPP of
      32: // 32-битный формат
      begin
        pixel := PDWORD(DWORD(ddsd2.lpSurface) + i * 4 + j * ddsd2.lPitch)^;

        g := ((pixel shr 8) and $000000FF);
        inc( dwPointer );
        pbyte(pointer(DWORD(pPixels) + dwPointer))^ := g;

        b := ((pixel shr 16) and $000000FF);
        inc( dwPointer );
        pbyte(pointer(DWORD(pPixels) + dwPointer))^ := b;

        r := ((pixel) and $000000FF);
        inc( dwPointer );
        pbyte(pointer(DWORD(pPixels) + dwPointer))^ := r;
      end;

      24: // 24-битный формат
      begin
        inc( dwPointer );
        pbyte(pointer(DWORD(pPixels) + dwPointer))^ := pbyte(DWORD(ddsd2.lpSurface) + i * 3 + 1 + j * ddsd2.lPitch)^;

        inc( dwPointer );
        pbyte(pointer(DWORD(pPixels) + dwPointer))^ := pbyte(DWORD(ddsd2.lpSurface) + i * 3 + 2 + j * ddsd2.lPitch)^;

        inc( dwPointer );
        pbyte(pointer(DWORD(pPixels) + dwPointer))^ := pbyte(DWORD(ddsd2.lpSurface) + i * 3 + 0 + j * ddsd2.lPitch)^;
      end;

      16: // 16-битный формат
      begin
        if ddsd2.ddpfPixelFormat.dwGBitMask = $07e0 then // формат 5-6-5 (современные видеокарты)
	begin
          pixel := PWORD(DWORD(ddsd2.lpSurface) + i * 2 + j * ddsd2.lPitch)^;

          r := 4 * ((pixel shr 5) and $003f);
          inc( dwPointer );
          pbyte(pointer(DWORD(pPixels) + dwPointer))^ := r;

          g := 8 * ((pixel shr 11) and $001f);
          inc( dwPointer );
          pbyte(pointer(DWORD(pPixels) + dwPointer))^ := g;

          b := 8 * ((pixel) and $001f);
          inc( dwPointer );
          pbyte(pointer(DWORD(pPixels) + dwPointer))^ := b
        end
        else // формат 5-5-5 (старые видеокарты)
	begin
          pixel := PWORD(DWORD(ddsd2.lpSurface) + i * 2 + j * ddsd2.lPitch)^;

          r := 8 * ((pixel shr 5) and $001f);
          inc( dwPointer );
          pbyte(pointer(DWORD(pPixels) + dwPointer))^ := r;

          g := 8 * ((pixel shr 10) and $001f);
          inc( dwPointer );
          pbyte(pointer(DWORD(pPixels) + dwPointer))^ := g;

          b := 8 * ((pixel) and $001f);
          inc( dwPointer );
          pbyte(pointer(DWORD(pPixels) + dwPointer))^ := b;
        end;
      end
      else exit; // case of (8 бит или менее)

    end;
  end;

  // разблокируем поверхность DirectDraw
  pSurface.Unlock( nil );

  //------------------------------

  // заполняем структуру BITMAPFILEHEADER
  fh.bfType          := $4D42; // 'B' 'M'
  fh.bfSize          := sizeof( BITMAPINFOHEADER ) + sizeof( BITMAPFILEHEADER ) +
                        dwWidth * dwHeight * dwBPP;
  fh.bfReserved1     := 0;
  fh.bfReserved2     := 0;
  fh.bfOffBits       := sizeof( BITMAPINFOHEADER ) + sizeof( BITMAPFILEHEADER );

  // заполняем структуру BITMAPINFOHEADER
  bi.biSize          := sizeof( BITMAPINFOHEADER );
  bi.biWidth         := dwWidth;
  bi.biHeight        := dwHeight;
  bi.biPlanes        := 1;
  bi.biBitCount      := 24;
  bi.biCompression   := BI_RGB;
  bi.biSizeImage     := 0;
  bi.biXPelsPerMeter := 10000;
  bi.biYPelsPerMeter := 10000;
  bi.biClrUsed       := 0;
  bi.biClrImportant  := 0;

  // записываем заголовок файла
  if WriteFile( hFile, fh, sizeof( BITMAPFILEHEADER ), dwBytesWritten, nil ) = BOOL(FALSE) then
  begin
    CloseHandle( hFile );
    exit;
  end;

  // записываем заголовок с информацией о файле
  if WriteFile( hFile, bi, sizeof( BITMAPINFOHEADER ), dwBytesWritten, nil ) = BOOL(FALSE) then
  begin
    CloseHandle( hFile );
    exit;
  end;

  // записываем битовые данные
  if WriteFile( hFile, pPixels^, dwWidth * dwHeight * 3, dwBytesWritten, nil ) = BOOL(FALSE) then
  begin
    CloseHandle( hFile );
    pPixels := nil;
    exit;
  end;

  // закрываем файл
  CloseHandle( hFile );
  pPixels := nil;

  result := true;
end;

end.