unit CaptureImage;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, ExtCtrls;

type
  TfmCaptureImage = class(TForm)
    btnCapture: TButton;
    procedure FormCreate(Sender: TObject);
    procedure FormPaint(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure btnCaptureClick(Sender: TObject);
  private
    { Private declarations }
    hdcScreen, hdcCompatible: HDC;
    hbmScreen, hOldBitmap: HBITMAP;
    bmpWidth, bmpHeight: Integer;
    Captured: LongBool;
  public
    { Public declarations }
  end;

var
  fmCaptureImage: TfmCaptureImage;

implementation

{$R *.dfm}

procedure TfmCaptureImage.FormCreate(Sender: TObject);
begin
  // создаем контекст устройства экрана
  hdcScreen := CreateDC('DISPLAY', nil, nil, nil);
  // создаем совместимый контекст устройства памяти
  hdcCompatible := CreateCompatibleDC(hdcScreen);
  bmpWidth := GetDeviceCaps(hdcScreen, HORZRES);
  bmpHeight := GetDeviceCaps(hdcScreen, VERTRES);
  // создаем соместимый точечный рисунок для hdcScreen
  hbmScreen := CreateCompatibleBitmap(hdcScreen, bmpWidth, bmpHeight);
  if hbmScreen <> 0 then
    hOldBitmap := SelectObject(hdcCompatible, hbmScreen)
  else
    hOldBitmap := 0;
  Captured := False;
end;

procedure TfmCaptureImage.FormPaint(Sender: TObject);
var
  hCurDC: HDC;
begin
  if Captured then
    begin
      hCurDC := GetDC(Handle);
      // масштабирует изображение на форму
      StretchBlt(hCurDC, 0, 0, Width, Height, hdcCompatible, 0, 0, bmpWidth, bmpHeight, SRCCOPY);
      ReleaseDC(Handle, hCurDC);
    end;
end;

procedure TfmCaptureImage.FormClose(Sender: TObject;
  var Action: TCloseAction);
begin
  // восстанавливаем точечный рисунок по умолчанию
  if hOldBitmap <> 0 then
    SelectObject(hdcCompatible, hOldBitmap);
  // удаляем совместимый точечный рисунок
  if hbmScreen <> 0 then
    DeleteObject(hbmScreen);
  // удаляем совместимый контекст устройства памяти
  if hdcCompatible <> 0 then
    DeleteDC(hdcCompatible);
  // удаляем контекст устройства экрана
  if hdcScreen <> 0 then
    DeleteDC(hdcScreen);
end;

procedure TfmCaptureImage.btnCaptureClick(Sender: TObject);
var
  hdcForm: HDC;
begin
  // прячем наше окно
  Hide;
  // сохраняем текущее изображение экрана
  Captured := BitBlt(hdcCompatible, 0, 0, bmpWidth, bmpHeight, hdcScreen, 0, 0, SRCCOPY);
  // показываем наше окно
  Show;
end;

end.
