program ScrShop;

 

uses

Windows;

 

procedure ApiScrCapture(FileName: String);

type

   TScr = array [0..1] of Byte;

   PScr = ^TScr;

var

   hBmp       : hBitmap;

   DeskDC     : hDC;

   DC         : hDC;

   BFH        : BITMAPFILEHEADER;

   BIH        : tagBITMAPINFO;

   ScrX, ScrY : Integer;

   F          : File;

   ScrSize    : Cardinal;

   Bits       : PScr;

begin

   SCRX     := GetSystemMetrics(SM_CXSCREEN);

   SCRY     := GetSystemMetrics(SM_CYSCREEN);

   ScrSize  := ScrX * ScrY * 3;

 

   GetMem(Bits, ScrSize);

 

   DeskDC   := GetDC(0);

   hBmp     := CreateCompatibleBitmap(DeskDC, ScrX, ScrY);

   DC       := CreateCompatibleDC(DeskDC);

 

   SelectObject(DC, hbmp);

   BitBlt(DC, 0, 0, SCRX, SCRY, DeskDC, 0, 0, SrcCopy);

 

   with BFH do

   begin

     bfType      := D42;

     bfSize      := SCRX * SCRY * 3 + SizeOf(BFH) + SizeOf(BIH);

     bfReserved1 := 0;

     bfReserved2 := 0;

     bfOffBits   := SizeOf(BFH) + SizeOf(BIH);

   end;

 

   with BIH.bmiHeader do

   begin

    biSize         := sizeof(BIH);

    biWidth        := SCRX;

    biHeight       := SCRY;

    biPlanes       := 1;

    biBitCount     := 24;

    biCompression  := BI_RGB;

    biSizeImage    := ScrSize;

    biClrImportant := 0;

   end;

 

   GetDiBits(DC, hbmp, 0, SCRY, Bits, BIH, DIB_RGB_COLORS);

   DeleteObject(hbmp);

   AssignFile(F, FileName);

   Rewrite(F, 1);

   Blockwrite(F, BFH, SizeOf(BFH));

   Blockwrite(F, BIH, SizeOf(BIH));

   Blockwrite(F, bits^, ScrSize);

   CloseFile(F);

   FreeMem(Bits);

end;

 

begin

   ApiScrCapture('1.bmp');

end.