procedure TMainForm.PreviewCaptureImage(Bmp: TBitmap);
begin
  FormCaptureImage.Image1.Picture.Bitmap := nil;
  FormCaptureImage.Image1.Picture.Bitmap.PixelFormat := pf32bit;
  FormCaptureImage.Image1.Picture.Bitmap.AlphaFormat := afDefined;

  //追加描画可能なように代入とする.Assignだと追加描画は不可
  FormCaptureImage.Image1.Picture.Bitmap := Bmp;
  FormCaptureImage.Image1.Update;

  FormCaptureImage.Show;
end;

procedure TMainForm.PreviewCaptureImage(Bmp: TBitmap);
begin
  FormCaptureImage.Image1.Picture.Bitmap := nil;

  FormCaptureImage.Image1.Picture.Bitmap.Assign(Bmp);
  FormCaptureImage.Image1.Update;

  FormCaptureImage.Show;
end;

program Project1;

uses
  Forms,
  Unit1 in 'Unit1.pas' {Form1},
  FormCaptureImageUnit in '..\FormCaptureImageUnit.pas' {FormCaptureImage};

{$R *.res}

begin
  Application.Initialize;
  Application.MainFormOnTaskbar := True;
  Application.CreateForm(TForm1, Form1);
  Application.CreateForm(TFormCaptureImage, FormCaptureImage);
  Application.Run;
end.

unit MainFormUnit;

interface

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

type
  TMainForm = class(TForm)
    Button1: TButton;
    Button2: TButton;
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
  private
    { Private 宣言 }
    function GetWindowRectForVista(hWindow: HWND): TRect;
    procedure PreviewCaptureImage(Bmp: TBitmap);
  public
    { Public 宣言 }
  end;

var
  MainForm: TMainForm;

implementation

uses FormCaptureImageUnit;

{$R *.dfm}

//-----------------------------------------------------------------------------
//  CAPTUREBLTは少なくともDelphi XE以前にはないので追加
//-----------------------------------------------------------------------------
const
  CAPTUREBLT = $40000000;

//=============================================================================
//  Windows Vista以降では，フォームのフレームの仕様が拡張されている
//  これを考慮したウィンドウのTRect構造体の値を取得
//=============================================================================
function TMainForm.GetWindowRectForVista(hWindow: HWND): TRect;
var
  ARect : TRect;
begin
  //Windows Vista以降は拡張フレーム
  if CheckWin32Version(6, 0) then begin
    //拡張したウィンドウのフレームのTRect構造体の値を取得
    DwmGetWindowAttribute(hWindow,
                          DWMWA_EXTENDED_FRAME_BOUNDS,
                          @ARect,
                          SizeOf(TRect));
  end else begin
    GetWindowRect(hWindow, ARect);
  end;
  Result := ARect;
end;

//=============================================================================
//  Windows Vista以降では，フォームのフレームの仕様が拡張されている
//  これを考慮しない従来の方法でのウィンドウのキャプチャ
//
//  このフォームのBorderStyleはbsSingleとなっている
//=============================================================================
procedure TMainForm.Button1Click(Sender: TObject);
var
  ScreenDC   : HDC;
  hTargetWnd : HWND;
  TargetRect : TRect;
  bmpOrigin  : TBitmap;
begin
  //キャプチャするのはこのフォーム
  hTargetWnd := Self.Handle;

  //キャプチャ対象ウィンドウのサイズと位置を取得
  GetWindowRect(hTargetWnd, TargetRect);

  //キャプチャーした画像を格納するビットマップを作成
  bmpOrigin             := TBitmap.Create;
  bmpOrigin.PixelFormat := pf32bit;
  bmpOrigin.Width       := TargetRect.Right  - TargetRect.Left;
  bmpOrigin.Height      := TargetRect.Bottom - TargetRect.Top;

  try
    //デスクトップのデバイスコンテキスを取得
    ScreenDC := CreateDC('DISPLAY', nil, nil, nil);
    try
      //指定矩形範囲をビットマップbmpOriginにBitBltする
      BitBlt(bmpOrigin.Canvas.Handle,
             0,
             0,
             TargetRect.Right  - TargetRect.Left,
             TargetRect.Bottom - TargetRect.Top,
             ScreenDC,
             TargetRect.Left,
             TargetRect.Top,
             SRCCOPY or CAPTUREBLT);
    finally
      DeleteDC(ScreenDC);
    end;

    //キャプチャした画像をプレビュー表示
    //bmpOrigin(TBitmap)がキャプチャしたビットマップ画像
    PreviewCaptureImage(bmpOrigin);
  finally
    FreeAndNil(bmpOrigin);
  end;
end;

//=============================================================================
//  Windows Vista以降では，フォームのフレームの仕様が拡張されている
//  これを考慮したウィンドウのキャプチャ
//
//  このフォームのBorderStyleはbsSingleとなっている
//=============================================================================
procedure TMainForm.Button2Click(Sender: TObject);
var
  ScreenDC   : HDC;
  hTargetWnd : HWND;
  TargetRect : TRect;
  bmpOrigin  : TBitmap;
begin
  //キャプチャするのはこのフォーム
  hTargetWnd := Self.Handle;

  //キャプチャ対象ウィンドウのサイズと位置を取得
  //Vista以降の角柱フレーム対応
  TargetRect := GetWindowRectForVista(hTargetWnd);

  //キャプチャーした画像を格納するビットマップを作成
  bmpOrigin             := TBitmap.Create;
  bmpOrigin.PixelFormat := pf32bit;
  bmpOrigin.Width       := TargetRect.Right  - TargetRect.Left;
  bmpOrigin.Height      := TargetRect.Bottom - TargetRect.Top;

  try
    //デスクトップのデバイスコンテキスを取得
    ScreenDC := CreateDC('DISPLAY', nil, nil, nil);
    try
      //指定矩形範囲をビットマップbmpOriginにBitBltする
      BitBlt(bmpOrigin.Canvas.Handle,
             0,
             0,
             TargetRect.Right  - TargetRect.Left,
             TargetRect.Bottom - TargetRect.Top,
             ScreenDC,
             TargetRect.Left,
             TargetRect.Top,
             SRCCOPY or CAPTUREBLT);
    finally
      DeleteDC(ScreenDC);
    end;

    //キャプチャした画像をプレビュー表示
    //bmpOrigin(TBitmap)がキャプチャしたビットマップ画像
    PreviewCaptureImage(bmpOrigin);
  finally
    FreeAndNil(bmpOrigin);
  end;
end;

//=============================================================================
//  キャプチャしたビットマップをプレビュー表示するメソッド
//  Imaage1のサイズを設定して描画する場合は，Image1.AutoSizeの値をFalseにする
//=============================================================================
procedure TMainForm.PreviewCaptureImage(Bmp: TBitmap);
begin
  //追加描画可能なように代入とする.Assignだと追加描画は不可
  FormCaptureImage.Image1.Picture.Bitmap := nil;
  FormCaptureImage.Image1.Picture.Bitmap := Bmp;
  FormCaptureImage.Image1.Update;

  FormCaptureImage.Show;
end;

end.

unit MainFormUnit;

interface

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

type
  TMainForm = class(TForm)
    Button1: TButton;
    Button2: TButton;
    Button3: TButton;
    Button4: TButton;
    Button5: TButton;
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure Button3Click(Sender: TObject);
    procedure Button4Click(Sender: TObject);
    procedure Button5Click(Sender: TObject);
  private
    { Private 宣言 }
    procedure PreviewCaptureImage(Bmp: TBitmap);
  public
    { Public 宣言 }
  end;

var
  MainForm: TMainForm;

implementation

uses FormCaptureImageUnit;

{$R *.dfm}

//-----------------------------------------------------------------------------
//  CAPTUREBLTは少なくともDelphi XE以前にはないので追加
//-----------------------------------------------------------------------------
const
  CAPTUREBLT = $40000000;

//=============================================================================
//  デスクトップのキャプチャ例 1
//=============================================================================
procedure TMainForm.Button1Click(Sender: TObject);
var
  ScreenDC   : HDC;
  TargetRect : TRect;
  bmpOrigin  : TBitmap;
begin
  //キャプチャ対象ウィンドウのサイズと位置を取得
  TargetRect := Screen.DesktopRect;

  //キャプチャーした画像を格納するビットマップを作成
  bmpOrigin             := TBitmap.Create;
  bmpOrigin.PixelFormat := pf32bit;
  bmpOrigin.Width       := TargetRect.Right  - TargetRect.Left;
  bmpOrigin.Height      := TargetRect.Bottom - TargetRect.Top;

  try
    //デスクトップのデバイスコンテキスを取得
    ScreenDC := CreateDC('DISPLAY', nil, nil, nil);
    try
      //指定矩形範囲をビットマップbmpOriginにBitBltする
      BitBlt(bmpOrigin.Canvas.Handle,
             0,
             0,
             TargetRect.Right  - TargetRect.Left,
             TargetRect.Bottom - TargetRect.Top,
             ScreenDC,
             TargetRect.Left,
             TargetRect.Top,
             SRCCOPY or CAPTUREBLT);
    finally
      DeleteDC(ScreenDC);
    end;

    //キャプチャした画像をプレビュー表示
    PreviewCaptureImage(bmpOrigin);
  finally
    FreeAndNil(bmpOrigin);
  end;
end;

//=============================================================================
//  デスクトップのキャプチャ例 2
//=============================================================================
procedure TMainForm.Button2Click(Sender: TObject);
var
  ScreenDC   : HDC;
  bmpOrigin  : TBitmap;
begin
  //キャプチャーした画像を格納するビットマップを作成
  bmpOrigin             := TBitmap.Create;
  bmpOrigin.PixelFormat := pf32bit;
  bmpOrigin.Width       := Screen.Width;
  bmpOrigin.Height      := Screen.Height;

  try
    //デスクトップのデバイスコンテキスを取得
    ScreenDC := CreateDC('DISPLAY', nil, nil, nil);
    try
      //指定矩形範囲をビットマップbmpOriginにBitBltする
      BitBlt(bmpOrigin.Canvas.Handle,
             0,
             0,
             Screen.Width,
             Screen.Height,
             ScreenDC,
             Screen.DesktopLeft,
             Screen.DesktopTop,
             SRCCOPY or CAPTUREBLT);
    finally
      DeleteDC(ScreenDC);
    end;

    //キャプチャした画像をプレビュー表示
    PreviewCaptureImage(bmpOrigin);
  finally
    FreeAndNil(bmpOrigin);
  end;
end;

//=============================================================================
//  デスクトップのキャプチャ例 3
//=============================================================================
procedure TMainForm.Button3Click(Sender: TObject);
var
  ScreenDC   : HDC;
  bmpOrigin  : TBitmap;
begin
  //キャプチャーした画像を格納するビットマップを作成
  bmpOrigin             := TBitmap.Create;
  bmpOrigin.PixelFormat := pf32bit;
  bmpOrigin.Width       := Screen.DesktopWidth;
  bmpOrigin.Height      := Screen.DesktopHeight;

  try
    //デスクトップのデバイスコンテキスを取得
    ScreenDC := CreateDC('DISPLAY', nil, nil, nil);
    try
      //指定矩形範囲をビットマップbmpOriginにBitBltする
      BitBlt(bmpOrigin.Canvas.Handle,
             0,
             0,
             Screen.DesktopWidth,
             Screen.DesktopHeight,
             ScreenDC,
             Screen.DesktopLeft,
             Screen.DesktopTop,
             SRCCOPY or CAPTUREBLT);
    finally
      DeleteDC(ScreenDC);
    end;

    //キャプチャした画像をプレビュー表示
    PreviewCaptureImage(bmpOrigin);
  finally
    FreeAndNil(bmpOrigin);
  end;
end;

//=============================================================================
//  ワークエリアのキャプチャ例 1
//=============================================================================
procedure TMainForm.Button4Click(Sender: TObject);
var
  ScreenDC   : HDC;
  TargetRect : TRect;
  bmpOrigin  : TBitmap;
begin
  //キャプチャ対象ウィンドウのサイズと位置を取得
  TargetRect := Screen.WorkAreaRect;

  //キャプチャーした画像を格納するビットマップを作成
  bmpOrigin             := TBitmap.Create;
  bmpOrigin.PixelFormat := pf32bit;
  bmpOrigin.Width       := TargetRect.Right  - TargetRect.Left;
  bmpOrigin.Height      := TargetRect.Bottom - TargetRect.Top;

  try
    //デスクトップのデバイスコンテキスを取得
    ScreenDC := CreateDC('DISPLAY', nil, nil, nil);

    try
      //指定矩形範囲をビットマップbmpOriginにBitBltする
      BitBlt(bmpOrigin.Canvas.Handle,
             0,
             0,
             TargetRect.Right  - TargetRect.Left,
             TargetRect.Bottom - TargetRect.Top,
             ScreenDC,
             TargetRect.Left,
             TargetRect.Top,
             SRCCOPY or CAPTUREBLT);
    finally
      DeleteDC(ScreenDC);
    end;

    //キャプチャした画像をプレビュー表示
    PreviewCaptureImage(bmpOrigin);
  finally
    FreeAndNil(bmpOrigin);
  end;
end;

//=============================================================================
//  ワークエリアのキャプチャ例 2
//=============================================================================
procedure TMainForm.Button5Click(Sender: TObject);
var
  ScreenDC   : HDC;
  bmpOrigin  : TBitmap;
begin
  //キャプチャーした画像を格納するビットマップを作成
  bmpOrigin             := TBitmap.Create;
  bmpOrigin.PixelFormat := pf32bit;
  bmpOrigin.Width       := Screen.WorkAreaWidth;
  bmpOrigin.Height      := Screen.WorkAreaHeight;

  try
    //デスクトップのデバイスコンテキスを取得
    ScreenDC := CreateDC('DISPLAY', nil, nil, nil);
    try
      //指定矩形範囲をビットマップbmpOriginにBitBltする
      BitBlt(bmpOrigin.Canvas.Handle,
             0,
             0,
             Screen.WorkAreaWidth,
             Screen.WorkAreaHeight,
             ScreenDC,
             Screen.WorkAreaLeft,
             Screen.WorkAreaTop,
             SRCCOPY or CAPTUREBLT);
    finally
      DeleteDC(ScreenDC);
    end;

    //キャプチャした画像をプレビュー表示
    PreviewCaptureImage(bmpOrigin);
  finally
    FreeAndNil(bmpOrigin);
  end;
end;

//=============================================================================
//  キャプチャしたビットマップをプレビュー表示するメソッド
//  Imaage1のサイズを設定して描画する場合は，Image1.AutoSizeの値をFalseにする
//=============================================================================
procedure TMainForm.PreviewCaptureImage(Bmp: TBitmap);
begin
  //追加描画可能なように代入とする.Assignだと追加描画は不可
  FormCaptureImage.Image1.Picture.Bitmap := nil;
  FormCaptureImage.Image1.Picture.Bitmap := Bmp;
  FormCaptureImage.Image1.Update;

  FormCaptureImage.Show;
end;

end.

unit MainFormUnit;

interface

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

type
  TMainForm = class(TForm)
    Button1: TButton;
    procedure Button1Click(Sender: TObject);
  private
    { Private 宣言 }
    function GetWindowRectForVista(hWindow: HWND): TRect;
    procedure PreviewCaptureImage(Bmp: TBitmap);
    procedure DifferentiateColor(BackColor: TColor; A1, B1: TBitmap);
  public
    { Public 宣言 }
  end;

var
  MainForm: TMainForm;

implementation

uses FormCaptureImageUnit, MMSystem;

{$R *.dfm}

//=============================================================================
//  Windows Vista以降では，フォームのフレームの仕様が拡張されている
//  これを考慮したウィンドウのTRect構造体の値を取得
//=============================================================================
function TMainForm.GetWindowRectForVista(hWindow: HWND): TRect;
var
  ARect : TRect;
begin
  //Windows Vista以降は拡張フレーム
  if CheckWin32Version(6, 0) then begin
    //拡張したウィンドウのフレームのTRect構造体の値を取得
    DwmGetWindowAttribute(hWindow,
                          DWMWA_EXTENDED_FRAME_BOUNDS,
                          @ARect,
                          SizeOf(TRect));
  end else begin
    GetWindowRect(hWindow, ARect);
  end;
  Result := ARect;
end;

//=============================================================================
//  Windows Vista以降では，フォーム下に影(シャドウウィンドウか)が表示される
//  この部分を調べるコード
//
//  このプロジェクトはApplication.MainFormOnTaskbar := False;としている
//=============================================================================
procedure TMainForm.Button1Click(Sender: TObject);

//CAPTUREBLTは少なくともDelphi XE以前にはないので定義
const
  CAPTUREBLT = $40000000;
var
  StartTime    : DWORD;
  ScreenDC     : HDC;
  hTargetWnd   : HWND;
  TargetRect   : TRect;
  bmpOrigin    : TBitmap;
  bmpBackColor : TBitmap;
  ColorBack    : TColor;
  BackForm     : TForm;
begin
  //指定時間が経過したらキャプチャ開始
  Starttime := timeGetTime;
  while (timeGetTime - StartTime) < 3000 do begin
    Sleep(10);
    Application.ProcessMessages;
  end;

  //その時アクティブなウィンドウをキャプチャー
  hTargetWnd := Windows.GetForegroundWindow;
  //背景色
  ColorBack := clGreen;

  //キャプチャ対象ウィンドウのサイズと位置を取得
  //Vista以降の拡張フレーム対応
  TargetRect := GetWindowRectForVista(hTargetWnd);

  //確認のために少し大きいサイズでキャプチャ
  TargetRect.Left   := TargetRect.Left   - 30;
  TargetRect.Top    := TargetRect.Top    - 30;
  TargetRect.Right  := TargetRect.Right  + 30;
  TargetRect.Bottom := TargetRect.Bottom + 30;

  //キャプチャーした画像を格納するビットマップを作成
  bmpOrigin             := TBitmap.Create;
  bmpOrigin.PixelFormat := pf32bit;
  bmpOrigin.Width       := TargetRect.Right  - TargetRect.Left;
  bmpOrigin.Height      := TargetRect.Bottom - TargetRect.Top;

  //背景色を指定したウィンドウのキャプチャー画用ビットマップ
  bmpBackColor             := TBitmap.Create;
  bmpBackColor.PixelFormat := pf32bit;
  bmpBackColor.Width       := TargetRect.Right  - TargetRect.Left;
  bmpBackColor.Height      := TargetRect.Bottom - TargetRect.Top;

  try
    //デスクトップのデバイスコンテキスを取得
    ScreenDC := CreateDC('DISPLAY', nil, nil, nil);

    //キャプチャー範囲をbmpOriginにBitBlt
    BitBlt(bmpOrigin.Canvas.Handle,
           0,
           0,
           TargetRect.Right  - TargetRect.Left,
           TargetRect.Bottom - TargetRect.Top,
           ScreenDC,
           TargetRect.Left,
           TargetRect.Top,
           SRCCOPY or CAPTUREBLT);

    //背景色用のフォームを作成
    BackForm := TForm.Create(Self);
    try
      BackForm.Position    := poDesigned;
      BackForm.BorderStyle := bsNone;
      //そのサイズと位置をキャプチャーする範囲の値と合わせる
      BackForm.SetBounds(TargetRect.Left,
                           TargetRect.Top,
                           TargetRect.Right  - TargetRect.Left,
                           TargetRect.Bottom - TargetRect.Top);
      //背景色で塗り潰す
      BackForm.Color := ColorBack;
      //表示する
      BackForm.Show;
      UpdateWindow(BackForm.Handle);

      //その上に目的のウィンドウを表示する
      SetForegroundWindow(hTargetWnd);
      //Windows XPではこれがないと描画が完了しない画像となる場合がある
      UpdateWindow(hTargetWnd);

      //その重ねた画像をビットマップbmpBackColorにBitBlt
      BitBlt(bmpBackColor.Canvas.Handle,
             0,
             0,
             TargetRect.Right  - TargetRect.Left,
             TargetRect.Bottom - TargetRect.Top,
             ScreenDC,
             TargetRect.Left,
             TargetRect.Top,
             SRCCOPY or CAPTUREBLT);

      //色が重ねっていないところを背景色にしてbmpOriginに返す
      //色が重なっていないところがウィンドウ影部分となる
      DifferentiateColor(BackForm.Color, bmpBackColor, bmpOrigin);
    finally
      DeleteDC(ScreenDC);
      FreeAndNil(BackForm);
    end;

    //キャプチャした画像をプレビュー表示
    PreviewCaptureImage(bmpOrigin);
  finally
    FreeAndNil(bmpOrigin);
    FreeAndNil(bmpBackColor);
  end;
end;

//=============================================================================
//  キャプチャしたビットマップをプレビュー表示するメソッド
//  Imaage1のサイズを設定して描画する場合は，Image1.AutoSizeの値をFalseにする
//=============================================================================
procedure TMainForm.PreviewCaptureImage(Bmp: TBitmap);
begin
  //追加描画可能なように代入とする.Assignだと追加描画は不可
  FormCaptureImage.Image1.Picture.Bitmap := nil;
  FormCaptureImage.Image1.Picture.Bitmap := Bmp;
  FormCaptureImage.Image1.Update;

  FormCaptureImage.Show;
end;

//=============================================================================
//  影の部分を除いた部分を指定色で塗り潰す
//
//  A1 背景がBackColorの矩形領域に，ウィンドを重ねた画像
//  B1 指定領域の背景もそのままキャプチャーした画像
//=============================================================================
procedure TMainForm.DifferentiateColor(BackColor: TColor; A1, B1: TBitmap);
var
  SizeX : Integer;
  SizeY : Integer;
  X     : Integer;
  Y     : Integer;
begin
  SizeX := A1.Width;
  SizeY := A1.Height;

  for X := 0 to SizeX - 1 do begin
    for Y := 0 to SizeY -1 do begin
      if A1.Canvas.Pixels[X, Y] = BackColor then begin
        B1.Canvas.Pixels[X, Y] := BackColor;
      end;
    end;
  end;
end;

end.

unit MainFormUnit;

interface

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

type
  TMainForm = class(TForm)
    Button1: TButton;
    procedure Button1Click(Sender: TObject);
  private
    { Private 宣言 }
    function GetWindowRectForVista(hWindow: HWND): TRect;
    procedure PreviewCaptureImage(Bmp: TBitmap);
  public
    { Public 宣言 }
  end;

var
  MainForm: TMainForm;

implementation

uses FormCaptureImageUnit, MMSystem;

{$R *.dfm}

//=============================================================================
//  Windows Vista以降では，フォームのフレームの仕様が拡張されている
//  これを考慮したウィンドウのTRect構造体の値を取得
//=============================================================================
function TMainForm.GetWindowRectForVista(hWindow: HWND): TRect;
var
  ARect : TRect;
begin
  //Windows Vista以降は拡張フレーム
  if CheckWin32Version(6, 0) then begin
    //拡張したウィンドウのフレームのTRect構造体の値を取得
    DwmGetWindowAttribute(hWindow,
                          DWMWA_EXTENDED_FRAME_BOUNDS,
                          @ARect,
                          SizeOf(TRect));
  end else begin
    GetWindowRect(hWindow, ARect);
  end;
  Result := ARect;
end;

//=============================================================================
//  Windows Vista以降では，フォーム下に影(シャドウウィンドウか)が表示される
//  この部分も含めてキャプチャするコード
//  単にキャプチャする範囲を影のある分だけ広げるだけ
//
//  このプロジェクトはApplication.MainFormOnTaskbar := False;としている
//=============================================================================
procedure TMainForm.Button1Click(Sender: TObject);

//CAPTUREBLTは少なくともDelphi XE以前にはないので定義
const
  CAPTUREBLT = $40000000;
var
  StartTime  : DWORD;
  ScreenDC   : HDC;
  hTargetWnd : HWND;
  TargetRect : TRect;
  bmpOrigin  : TBitmap;
begin
  //指定時間が経過したらキャプチャ開始
  Starttime := timeGetTime;
  while (timeGetTime - StartTime) < 3000 do begin
    Sleep(100);
    Application.ProcessMessages;
  end;

  //その時アクティブなウィンドウをキャプチャー
  hTargetWnd := Windows.GetForegroundWindow;

  //キャプチャ対象ウィンドウのサイズと位置を取得
  //Vista以降の拡張フレーム対応
  TargetRect := GetWindowRectForVista(hTargetWnd);

  //影の部分を追加
  if CheckWin32Version(6, 0) then begin
    TargetRect.Left   := TargetRect.Left   - 11;
    TargetRect.Top    := TargetRect.Top    - 11;
    TargetRect.Right  := TargetRect.Right  + 16;
    TargetRect.Bottom := TargetRect.Bottom + 18;
  end;

  //キャプチャーした画像を格納するビットマップを作成
  bmpOrigin             := TBitmap.Create;
  bmpOrigin.PixelFormat := pf32bit;
  bmpOrigin.Width       := TargetRect.Right  - TargetRect.Left;
  bmpOrigin.Height      := TargetRect.Bottom - TargetRect.Top;

  try
    //デスクトップのデバイスコンテキスを取得
    ScreenDC := CreateDC('DISPLAY', nil, nil, nil);
    try
      //キャプチャー範囲をbmpOriginにBitBlt
      BitBlt(bmpOrigin.Canvas.Handle,
             0,
             0,
             TargetRect.Right  - TargetRect.Left,
             TargetRect.Bottom - TargetRect.Top,
             ScreenDC,
             TargetRect.Left,
             TargetRect.Top,
             SRCCOPY or CAPTUREBLT);
    finally
      DeleteDC(ScreenDC);
    end;

    //キャプチャした画像をプレビュー表示
    PreviewCaptureImage(bmpOrigin);
  finally
    FreeAndNil(bmpOrigin);
  end;
end;

//=============================================================================
//  キャプチャしたビットマップをプレビュー表示するメソッド
//  Imaage1のサイズを設定して描画する場合は，Image1.AutoSizeの値をFalseにする
//=============================================================================
procedure TMainForm.PreviewCaptureImage(Bmp: TBitmap);
begin
  //追加描画可能なように代入とする.Assignだと追加描画は不可
  FormCaptureImage.Image1.Picture.Bitmap := nil;
  FormCaptureImage.Image1.Picture.Bitmap := Bmp;
  FormCaptureImage.Image1.Update;

  FormCaptureImage.Show;
end;

end.

unit MainFormUnit;

interface

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

type
  TMainForm = class(TForm)
    Button1: TButton;
    ColorBox1: TColorBox;
    procedure FormShow(Sender: TObject);
    procedure Button1Click(Sender: TObject);
  private
    { Private 宣言 }
    function GetWindowRectForVista(hWindow: HWND): TRect;
    procedure PreviewCaptureImage(Bmp: TBitmap);
  public
    { Public 宣言 }
  end;

var
  MainForm: TMainForm;

implementation

uses FormCaptureImageUnit, MMSystem;

{$R *.dfm}

//=============================================================================
//  フォームを表示した時の処理
//=============================================================================
procedure TMainForm.FormShow(Sender: TObject);
begin
  //背景色のデフォルト設定
  ColorBox1.Selected := clWhite;
end;

//=============================================================================
//  Windows Vista以降では，フォームのフレームの仕様が拡張されている
//  これを考慮したウィンドウのTRect構造体の値を取得
//=============================================================================
function TMainForm.GetWindowRectForVista(hWindow: HWND): TRect;
var
  ARect : TRect;
begin
  //Windows Vista以降は拡張フレーム
  if CheckWin32Version(6, 0) then begin
    //拡張したウィンドウのフレームのTRect構造体の値を取得
    DwmGetWindowAttribute(hWindow,
                          DWMWA_EXTENDED_FRAME_BOUNDS,
                          @ARect,
                          SizeOf(TRect));
  end else begin
    GetWindowRect(hWindow, ARect);
  end;
  Result := ARect;
end;

//=============================================================================
//  背景色を指定したキャプチャ
//  全体を塗り潰したフォームの上に，目的のウィンドウを表示してキャプチャ
//
//  このプロジェクトはApplication.MainFormOnTaskbar := False;としている
//=============================================================================
procedure TMainForm.Button1Click(Sender: TObject);

//CAPTUREBLTは少なくともDelphi XE以前にはないので定義
const
  CAPTUREBLT = $40000000;
var
  StartTime  : DWORD;
  ScreenDC   : HDC;
  hTargetWnd : HWND;
  TargetRect : TRect;
  bmpOrigin  : TBitmap;
  BackForm   : TForm;
begin
  //指定時間が経過したらキャプチャ開始
  Starttime := timeGetTime;
  while (timeGetTime - StartTime) < 3000 do begin
    Sleep(100);
    Application.ProcessMessages;
  end;

  //その時アクティブなウィンドウをキャプチャー
  hTargetWnd := Windows.GetForegroundWindow;

  //キャプチャ対象ウィンドウのサイズと位置を取得
  //Vista以降の拡張フレーム対応
  TargetRect := GetWindowRectForVista(hTargetWnd);

  //影の部分を追加
  if CheckWin32Version(6, 0) then begin
    TargetRect.Left   := TargetRect.Left   - 11;
    TargetRect.Top    := TargetRect.Top    - 11;
    TargetRect.Right  := TargetRect.Right  + 16;
    TargetRect.Bottom := TargetRect.Bottom + 18;
  end;

  //キャプチャーした画像を格納するビットマップを作成
  bmpOrigin             := TBitmap.Create;
  bmpOrigin.PixelFormat := pf32bit;
  bmpOrigin.Width       := TargetRect.Right  - TargetRect.Left;
  bmpOrigin.Height      := TargetRect.Bottom - TargetRect.Top;

  try
    //デスクトップのデバイスコンテキスを取得
    ScreenDC := CreateDC('DISPLAY', nil, nil, nil);

    //背景色要のフォームを作成
    BackForm := TForm.Create(Self);
    try
      BackForm.Position    := poDesigned;
      BackForm.BorderStyle := bsNone;
      //そのサイズと位置をキャプチャーする範囲の値と合わせる
      BackForm.SetBounds(TargetRect.Left,
                           TargetRect.Top,
                           TargetRect.Right  - TargetRect.Left,
                           TargetRect.Bottom - TargetRect.Top);
      //背景色で塗り潰す
      BackForm.Color := ColorBox1.Selected;
      //表示する
      BackForm.Show;
      BackForm.Repaint;
      //少しタイムラグが必要
      Sleep(20);

      //その上に目的のウィンドウを表示する
      SetForegroundWindow(hTargetWnd);
      //Windows XPではこれがないと描画が完了しない画像となる場合がある
      UpdateWindow(hTargetWnd);

      //その重ねた画像をビットマップbmpBackColorにBitBlt
      BitBlt(bmpOrigin.Canvas.Handle,
             0,
             0,
             TargetRect.Right  - TargetRect.Left,
             TargetRect.Bottom - TargetRect.Top,
             ScreenDC,
             TargetRect.Left,
             TargetRect.Top,
             SRCCOPY or CAPTUREBLT);
    finally
      DeleteDC(ScreenDC);
      FreeAndNil(BackForm);
    end;

    //キャプチャした画像をプレビュー表示
    PreviewCaptureImage(bmpOrigin);
  finally
    FreeAndNil(bmpOrigin);
  end;
end;

//=============================================================================
//  キャプチャしたビットマップをプレビュー表示するメソッド
//  Imaage1のサイズを設定して描画する場合は，Image1.AutoSizeの値をFalseにする
//=============================================================================
procedure TMainForm.PreviewCaptureImage(Bmp: TBitmap);
begin
  //追加描画可能なように代入とする.Assignだと追加描画は不可
  FormCaptureImage.Image1.Picture.Bitmap := nil;
  FormCaptureImage.Image1.Picture.Bitmap := Bmp;
  FormCaptureImage.Image1.Update;

  FormCaptureImage.Show;
end;

end.

unit MainFormUnit;

interface

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

type
  TMainForm = class(TForm)
    Button1: TButton;
    CheckBox1: TCheckBox;
    procedure Button1Click(Sender: TObject);
  private
    { Private 宣言 }
    function GetWindowRectForVista(hWindow: HWND): TRect;
    procedure PreviewCaptureImage(Bmp: TBitmap);
    procedure CaptureWindowImage(ATargetWnd: HWND; ATargetRect: TRect;
      ATargetBmp: TBitmap; ANeedShadow: Boolean = True; ABackColor: TColor = clNone);
  public
    { Public 宣言 }
  end;

var
  MainForm: TMainForm;

implementation

uses
  FormCaptureImageUnit,
  MMSystem;

{$R *.dfm}

//-----------------------------------------------------------------------------
//  Windows Vista以降では，フォームのフレームの仕様が拡張されている
//  これを考慮したウィンドウのTRect構造体の値を取得
//-----------------------------------------------------------------------------
function TMainForm.GetWindowRectForVista(hWindow: HWND): TRect;
var
  ARect : TRect;
begin
  //Windows Vista以降は拡張フレーム
  if CheckWin32Version(6, 0) then begin
    //拡張したウィンドウのフレームのTRect構造体の値を取得
    DwmGetWindowAttribute(hWindow,
                          DWMWA_EXTENDED_FRAME_BOUNDS,
                          @ARect,
                          SizeOf(TRect));
  end else begin
    GetWindowRect(hWindow, ARect);
  end;
  Result := ARect;
end;

//=============================================================================
//  アルファチャンネル付きキャプチャ
//  このプロジェクトはApplication.MainFormOnTaskbar := False;としている
//=============================================================================
procedure TMainForm.Button1Click(Sender: TObject);
var
  LStartTime  : DWORD;
  LhTargetWnd : HWND;
  LWndRect    : TRect;
  LBitmap     : TBitmap;
begin
  //指定時間が経過したらキャプチャ開始
  LStartTime := timeGetTime;
  while (timeGetTime - LStartTime) < 3000 do begin
    Sleep(100);
    Application.ProcessMessages;
  end;

  //その時アクティブなウィンドウをキャプチャー
  LhTargetWnd := Windows.GetForegroundWindow;

  //キャプチャ対象ウィンドウのサイズと位置を取得
  //Vista以降の拡張フレーム対応
  LWndRect := GetWindowRectForVista(LhTargetWnd);

  //影の部分を追加
  if CheckBox1.Checked then begin
    if CheckWin32Version(6, 0) then begin
      LWndRect.Left   := LWndRect.Left   - 11;
      LWndRect.Top    := LWndRect.Top    - 11;
      LWndRect.Right  := LWndRect.Right  + 16;
      LWndRect.Bottom := LWndRect.Bottom + 18;
    end;
  end;

  //キャプチャーした画像を格納するビットマップを作成
  LBitmap := TBitmap.Create;
  try
    //アルファチャンネル付きキャプチャ実行
    CaptureWindowImage(LhTargetWnd, LWndRect, LBitmap, True, clNone);

    //取得したビットマップをプレビュー表示
    PreviewCaptureImage(LBitmap);
  finally
    FreeAndNil(LBitmap);
  end;
end;

//-----------------------------------------------------------------------------
//  キャプチャしたビットマップをプレビュー表示するメソッド
//  Imaage1のサイズを設定して描画する場合は，Image1.AutoSizeの値をFalseにする
//-----------------------------------------------------------------------------
procedure TMainForm.PreviewCaptureImage(Bmp: TBitmap);
begin
  //追加描画可能なように代入とする.Assignだと追加描画は不可
  FormCaptureImage.Image1.Picture.Bitmap := nil;
  FormCaptureImage.Image1.Picture.Bitmap := Bmp;
  FormCaptureImage.Image1.Update;

  FormCaptureImage.Show;
end;

//-----------------------------------------------------------------------------
//  背景色を指定したキャプチャ画像を取得する関数
//  指定したウィンドウハンドルのウィンドウ専用
//  戻り値はATargetBmp
//  ATargetBmpは呼出し側で生成する(サイズはこの関数内で設定する)
//
//  ATargetWnd  : 対象のウィンドウのハンドル
//  ATargetRect : 対象のウィンドウのキャプチャ範囲
//                影の領域を踏める場合はその部分を含めたサイズ
//  ATargetBmp  : 戻り値のビットマップ(呼出し側で生成してく．サイズの指定は不要)
//  ANeedShadow : ウィンドウの半透明の影を描画するか
//                ウィンドウの影を表示しない設定の時はこの指定は無効
//                デフォルトはTrue
//  ABackColor  : 背景色．
//                clNone(デフォルト)の時は背景がARGB(0,0,0,0)の透明色になる
//
//  影の表示・非表示の切り換えはSystemParametersInfoを使用する方法がある
//  Windows Vistaには影の表示・非表示の設定はない．Windows 7以降の機能
//-----------------------------------------------------------------------------
procedure TMainForm.CaptureWindowImage(ATargetWnd: HWND;
  ATargetRect: TRect; ATargetBmp: TBitmap; ANeedShadow: Boolean;
  ABackColor: TColor);

  //---------------------------------------------------------------------------
  //  関数内関数
  //  背景を黒にしたキャプチャ画像と背景を白にしたキャプチャ画像
  //  この2つから半透明のアルファチャンネル影付きのビットマップを作成する
  //
  //  ABackBmp : 畏敬を黒にしてキャプチャしたビットマップ画像
  //  ADstBmp  : 畏敬を白にしてキャプチャしたビットマップ画像
  //---------------------------------------------------------------------------
  procedure DeffBitmap(ABackBmp: TBitmap; ADstBmp: TBitmap;
    ANeedDropShadow: Boolean = True; ABackColor: TColor = clNone);
   type
     TRGBQArray = array [0..High(Integer) div 4 - 1] of RGBQUAD;
     PRGBQArray = ^TRGBQArray;
  var
    LPosY           : Integer;
    LPosX           : Integer;
    LpBackQuadArray : PRGBQArray;
    LpDstQuadArray  : PRGBQArray;
    LBackBmpRValue  : Byte;
    LBackBmpGValue  : Byte;
    LBackBmpBValue  : Byte;
    LpDstBmpARGB    : RGBQUAD;
    LDstBmpAlpha    : Single;
    LDstBmpRValue   : Byte;
    LDstBmpGValue   : Byte;
    LDstBmpBValue   : Byte;
    LBackAValue     : Byte;
    LBackRValue     : Byte;
    LBackGValue     : Byte;
    LBackBValue     : Byte;
  begin
    if ABackColor = clNone then begin
      LBackAValue := 0;
      LBackRValue := 0;
      LBackGValue := 0;
      LBackBValue := 0;
    end else begin
      LBackAValue := $FF;
      LBackRValue := GetRValue(ABackColor);
      LBackGValue := GetGValue(ABackColor);
      LBackBValue := GetBValue(ABackColor);
    end;

    ABackBmp.Canvas.Lock;
    ADstBmp.Canvas.Lock;

    for LPosY := 0 to ABackBmp.Height - 1 do begin
      //ScanLineを使用した方が処理が速い
      LpBackQuadArray := ABackBmp.ScanLine[LPosY];
      LpDstQuadArray  := ADstBmp.ScanLine[LPosY];

      for LPosX := 0 to ABackBmp.Width - 1 do begin

        LBackBmpRValue := LpBackQuadArray[LPosX].rgbRed;
        LBackBmpGValue := LpBackQuadArray[LPosX].rgbGreen;
        LBackBmpBValue := LpBackQuadArray[LPosX].rgbBlue;

        LDstBmpRValue := LpDstQuadArray[LPosX].rgbRed;
        LDstBmpGValue := LpDstQuadArray[LPosX].rgbGreen;
        LDstBmpBValue := LpDstQuadArray[LPosX].rgbBlue;

        //両方のビットマップの色の差を計算
        LDstBmpRValue := Abs(LBackBmpRValue - LDstBmpRValue);
        LDstBmpGValue := Abs(LBackBmpGValue - LDstBmpGValue);
        LDstBmpBValue := Abs(LBackBmpBValue - LDstBmpBValue);

        //---------------------------------------------------------------------
        //  色を加算して3等分をアルファ値とする
        //  多色アルファブレンドでは重み付けをすることもある
        //  本サンプルでは黒の単色の半透明の影なのでこの計算とする
        //  演算誤差による現象を回避するために実数演算とする
        //---------------------------------------------------------------------

        LDstBmpAlpha := 255.0 - (LDstBmpRValue + LDstBmpGValue + LDstBmpBValue) / 3.0;

        if LDstBmpAlpha <> 0 then begin
  　　    //演算誤差による現象を回避するために実数演算とし，結果のみByteとする
          LDstBmpRValue := Byte(Trunc(LBackBmpRValue * 255.0 / LDstBmpAlpha));
          LDstBmpGValue := Byte(Trunc(LBackBmpGValue * 255.0 / LDstBmpAlpha));
          LDstBmpBValue := Byte(Trunc(LBackBmpBValue * 255.0 / LDstBmpAlpha));
        end else begin
          LDstBmpRValue := 0;
          LDstBmpGValue := 0;
          LDstBmpBValue := 0;
        end;

        LpDstBmpARGB.rgbRed   := LDstBmpRValue;
        LpDstBmpARGB.rgbGreen := LDstBmpGValue;
        LpDstBmpARGB.rgbBlue  := LDstBmpBValue;

        //影を必要としない場合は一定の不透明度以下のピクセルを透明色にする
        //影が必要ない場合とは影の領域をキャプチャしない時
        if ANeedDropShadow then begin
          LpDstBmpARGB.rgbReserved := Trunc(LDstBmpAlpha);
        end else begin
          if (Trunc(LDstBmpAlpha) < 200) then begin
            LpDstBmpARGB.rgbReserved := LBackAValue;
            LpDstBmpARGB.rgbRed      := LBackRValue;
            LpDstBmpARGB.rgbGreen    := LBackGValue;
            LpDstBmpARGB.rgbBlue     := LBackBValue;
          end else begin
            LpDstBmpARGB.rgbReserved := Trunc(LDstBmpAlpha);
          end;
        end;

        LpDstQuadArray[LPosX] := LpDstBmpARGB;
      end;
    end;

    ABackBmp.Canvas.Unlock;
    ADstBmp.Canvas.Unlock;

    //これにしないと結果が反映されない
    ADstBmp.AlphaFormat := afDefined;
  end;
  //---------------------------------------------------------------------------

const
  CAPTUREBLT = $40000000;
var
  LWidth        : Integer;
  LHeight       : Integer;
  LScreenDC     : HDC;
  LbmpBackColor : TBitmap;
  LBackForm     : TForm;
  LHasWndShdow  : Boolean;
  LShadowCheck  : Boolean;
begin
  //システムがウィンドウの影を表示する設定になっているかを調べる
  SystemParametersInfo(SPI_GETDROPSHADOW, 0, @LHasWndShdow, 0);
  if LHasWndShdow = False then ANeedShadow := False;

  ATargetBmp.PixelFormat := pf32bit;

  //デスクトップのデバイスコンテキスを取得
  LScreenDC := CreateDC('DISPLAY', nil, nil, nil);

  LWidth  := ATargetRect.Right - ATargetRect.Left;
  LHeight := ATargetRect.Bottom - ATargetRect.Top;
  ATargetBmp.SetSize(LWidth, LHeight);

  //キャプチャーした画像を格納するビットマップを作成
  LbmpBackColor := TBitmap.Create;
  try
    LbmpBackColor.PixelFormat := pf32bit;
    LbmpBackColor.SetSize(LWidth, LHeight);

    //背景色要のフォームを作成
    LBackForm := TForm.Create(Self);
    try
      LBackForm.Position    := poDesigned;
      LBackForm.BorderStyle := bsNone;
      //そのサイズと位置をキャプチャーする範囲の値と合わせる
      LBackForm.SetBounds(ATargetRect.Left, ATargetRect.Top, LWidth, LHeight);

      //背景色は黒とする
      //ウィンドウの影を表示しない設定で背景を透明にしない時はその色にする
      LShadowCheck := (not LHasWndShdow) and (ABackColor <> clNone);
      LShadowCheck := LShadowCheck or (ANeedShadow and (ABackColor <> clNone));

      if LShadowCheck then begin
        LBackForm.Color := ABackColor;
      end else begin
        LBackForm.Color := clBlack;
      end;
      //表示する
      LBackForm.Show;
      LBackForm.Repaint;
      //少しタイムラグが必要
      Sleep(10);

      //その上に目的のウィンドウを表示する
      SetForegroundWindow(ATargetWnd);
      //Windows XPではこれがないと描画が完了しない画像となる場合がある
      UpdateWindow(ATargetWnd);
      Sleep(10);

      //背景色が黒のウィンドウをキャプチャ
      BitBlt(LbmpBackColor.Canvas.Handle,
             0, 0, LWidth, LHeight,
             LScreenDC,
             ATargetRect.Left, ATargetRect.Top, SRCCOPY or CAPTUREBLT);

      //今度は背景色を白とする
      if LShadowCheck then begin
        ATargetBmp.Assign(LbmpBackColor);
      end else begin
        LBackForm.Color := clWhite;
        LBackForm.Repaint;
        Sleep(10);

        //背景色を白にして目的のウィンドウをキャプチャ
        //背景が白の矩形ウインドウの上に影付きのウィンドウの画像が描画される
        BitBlt(ATargetBmp.Canvas.Handle,
               0, 0, LWidth, LHeight,
               LScreenDC,
               ATargetRect.Left, ATargetRect.Top, SRCCOPY or CAPTUREBLT);

        //アルファーチャンネル処理
        //結果は第2引数のTBitmap
        DeffBitmap(LbmpBackColor, ATargetBmp, ANeedShadow, ABackColor);
      end;
    finally
      FreeAndNil(LBackForm);
    end;
  finally
    DeleteDC(LScreenDC);
    FreeAndNil(LbmpBackColor);
  end;
end;

end.

unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    Button1: TButton;
    procedure Button1Click(Sender: TObject);
  private
    { Private 宣言 }
    procedure PreviewCaptureImage(Bmp: TBitmap);
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

uses
  FormCaptureImageUnit;

{$R *.dfm}

//=============================================================================
//  アルファチャンネル付きでキャプチャして保存したビットマップを表示
//
//  アルファチャンネル表示するには，AlphaFormatをafDefinedにする
//  AlphaFormatのデフォルト値はafIgnored

//  透過状態の確認のためにプレビュー画面の背景に画像を表示する例
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
var
  LbmpOrigin : TBitmap;
  LbmpBack   : TBitmap;
begin
  LbmpOrigin := TBitmap.Create;
  LbmpBack   := TBitmap.Create;
  try
    //プレビュー画面に表示するびっとマップ画像
    LbmpOrigin.LoadFromFile('100.bmp');
    LbmpOrigin.AlphaFormat := afDefined;

    //プレビューフォーム上のTScrollBoxに背景画像を指定
    LbmpBack.LoadFromFile('backTexture_01.bmp');
    FormCaptureImage.ScrollBox1.Brush.Bitmap := LbmpBack;
    PreviewCaptureImage(LbmpOrigin);
  finally
    //解放処理
    FreeAndNil(LbmpOrigin);
    FreeAndNil(LbmpBack);
  end;
end;

//=============================================================================
//  キャプチャしたビットマップをプレビュー表示するメソッド
//  Imaage1のサイズを設定して描画する場合は，Image1.AutoSizeの値をFalseにする
//=============================================================================
procedure TForm1.PreviewCaptureImage(Bmp: TBitmap);
begin
  //追加描画可能なように代入とする.Assignだと追加描画は不可
  FormCaptureImage.Image1.Picture.Bitmap := nil;

  FormCaptureImage.Image1.Picture.Bitmap := Bmp;
  FormCaptureImage.Image1.Update;

  FormCaptureImage.Show;
end;

end.

unit Unit2;

interface

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

type
  TForm1 = class(TForm)
    Button1: TButton;
    Image1: TImage;
    OpenPictureDialog1: TOpenPictureDialog;
    procedure Button1Click(Sender: TObject);
  private
    { Private 宣言 }
    ADir : String;
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

//=============================================================================
//  アルファチャンネル付きでキャプチャして保存したビットマップを表示
//
//  アルファチャンネル表示するには，AlphaFormatをafDefinedにする
//  AlphaFormatのデフォルト値はafIgnored
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
begin
  if ADir = '' then begin
    OpenPictureDialog1.InitialDir := ExtractFilePath(Application.ExeName);
  end else begin
    OpenPictureDialog1.InitialDir := ADir;
  end;

  if OpenPictureDialog1.Execute then begin
    Image1.Picture.Bitmap.LoadFromFile(OpenPictureDialog1.FileName);
    Image1.Picture.Bitmap.AlphaFormat := afDefined;
    ADir := ExtractFileDir(OpenPictureDialog1.FileName);
  end;
end;

end.

unit MainFormUnit;

interface

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

type
  TMainForm = class(TForm)
    Button1: TButton;
    CheckBox1: TCheckBox;
    procedure Button1Click(Sender: TObject);
  private
    { Private 宣言 }
    function GetWindowRectForVista(hWindow: HWND): TRect;
    procedure PreviewCaptureImage(Bmp: TBitmap);
  public
    { Public 宣言 }
  end;

var
  MainForm: TMainForm;

implementation

uses
  FormCaptureImageUnit,
  MMSystem;

{$R *.dfm}

// -----------------------------------------------------------------------------
// Windows Vista以降では，フォームのフレームの仕様が拡張されている
// これを考慮したウィンドウのTRect構造体の値を取得
// -----------------------------------------------------------------------------
function TMainForm.GetWindowRectForVista(hWindow: HWND): TRect;
var
  LRect: TRect;
begin
  // Windows Vista以降は拡張フレーム
  if CheckWin32Version(6, 0) then begin
    // 拡張したウィンドウのフレームのTRect構造体の値を取得
    DwmGetWindowAttribute(hWindow, DWMWA_EXTENDED_FRAME_BOUNDS, @LRect, SizeOf(TRect));
  end else begin
    GetWindowRect(hWindow, LRect);
  end;
  Result := LRect;
end;

// =============================================================================
//  [ウィンドウの下に影を表示する]の設定の切り換え
// このプロジェクトはApplication.MainFormOnTaskbar := False;としている
// =============================================================================
procedure TMainForm.Button1Click(Sender: TObject);
const
  CAPTUREBLT = $40000000;
var
  LStartTime    : DWORD;
  LhTargetWnd   : HWND;
  LWndRect      : TRect;
  LScreenDC     : HDC;
  LBitmap       : TBitmap;
  LhasWndShadow : Boolean;
begin
  // 指定時間が経過したらキャプチャ開始
  LStartTime := timeGetTime;
  while (timeGetTime - LStartTime) < 3000 do begin
    Sleep(100);
    Application.ProcessMessages;
  end;

  // その時アクティブなウィンドウをキャプチャー
  LhTargetWnd := Windows.GetForegroundWindow;

  // キャプチャ対象ウィンドウのサイズと位置を取得
  // Vista以降の拡張フレーム対応
  LWndRect := GetWindowRectForVista(LhTargetWnd);

  // 影の部分を追加
  if CheckWin32Version(6, 0) then begin
    LWndRect.Left   := LWndRect.Left - 11;
    LWndRect.Top    := LWndRect.Top - 11;
    LWndRect.Right  := LWndRect.Right + 16;
    LWndRect.Bottom := LWndRect.Bottom + 18;
  end;


  //システムの[ウィンドウの下に影を表示する]の設定を取得
  SystemParametersInfo(SPI_GETDROPSHADOW, 0, @LHasWndShadow, 0);

  //システムの[ウィンドウの下に影を表示する]を設定
  //CheckBox1.Checkedの値を引数にすれば1行で済む
  if (CheckBox1.Checked) then begin
    SystemParametersInfo(SPI_SETDROPSHADOW, 0, Pointer(True), 0);
  end else begin
    SystemParametersInfo(SPI_SETDROPSHADOW, 0, Pointer(False), 0);
  end;

  // キャプチャーした画像を格納するビットマップを作成
  LBitmap := TBitmap.Create;
  LBitmap.PixelFormat := pf32bit;
  LBitmap.SetSize(LWndRect.Right - LWndRect.Left, LWndRect.Bottom - LWndRect.Top);
  try
    // デスクトップのデバイスコンテキスを取得
    LScreenDC := CreateDC('DISPLAY', nil, nil, nil);
    try
      // キャプチャー範囲をビットマップに描画
      BitBlt(LBitmap.Canvas.Handle,
             0,
             0,
             LWndRect.Right - LWndRect.Left,
             LWndRect.Bottom - LWndRect.Top,
             LScreenDC,
             LWndRect.Left,
             LWndRect.Top,
        SRCCOPY or CAPTUREBLT);
    finally
      DeleteDC(LScreenDC);
    end;

    // キャプチャした画像をプレビュー表示
    PreviewCaptureImage(LBitmap);
  finally
    FreeAndNil(LBitmap);
  end;

  //システムの[ウィンドウの下に影を表示する]の設定を元に戻しておく
  SystemParametersInfo(SPI_SETDROPSHADOW, 0, Pointer(LhasWndShadow), 0);
end;

// -----------------------------------------------------------------------------
// キャプチャしたビットマップをプレビュー表示するメソッド
// Imaage1のサイズを設定して描画する場合は，Image1.AutoSizeの値をFalseにする
// -----------------------------------------------------------------------------
procedure TMainForm.PreviewCaptureImage(Bmp: TBitmap);
begin
  // 追加描画可能なように代入とする.Assignだと追加描画は不可
  FormCaptureImage.Image1.Picture.Bitmap := nil;
  FormCaptureImage.Image1.Picture.Bitmap := Bmp;
  FormCaptureImage.Image1.Update;

  FormCaptureImage.Show;
end;

end.

unit MainFormUnit;

interface

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

type
  TMainForm = class(TForm)
    Button1: TButton;
    Panel1: TPanel;
    Button2: TButton;
    Panel2: TPanel;
    Button3: TButton;
    Button4: TButton;
    Button5: TButton;
    Edit1: TEdit;
    Memo1: TMemo;
    procedure Button1Click(Sender: TObject);
  private
    { Private 宣言 }
  public
    { Public 宣言 }
  end;

var
  MainForm: TMainForm;

implementation

uses MMSystem;

{$R *.dfm}

type
  TWndInfo = record
    hWindow : HWND;
    pt      : TPoint;
  end;
  PWndInfo= ^TWndInfo;

//-----------------------------------------------------------------------------
//  ウィンドウのタイトルを取得する関数
//-----------------------------------------------------------------------------
function GetWindowTitleStr(hWindow: HWND): String;
var
  Buffer : array[0..MAX_PATH-1] of Char;
  Len    : Integer;
begin
  FillChar(Buffer, SizeOf(Buffer), #0);
  Len := GetWindowText(hWindow, Buffer, Length(Buffer));
  if Len > 0 then Result := Buffer else Result := '';
end;

//-----------------------------------------------------------------------------
//  ウィンドウのクラス名を取得する関数
//-----------------------------------------------------------------------------
function GetWindowClassNameStr(hWindow: HWND): String;
var
  Buffer : array[0..MAX_PATH-1] of Char;
  Len    : Integer;
begin
  FillChar(Buffer, SizeOf(Buffer), #0);
  Len := GetClassName(hWindow, Buffer, Length(Buffer));
  if Len > 0 then Result := Buffer else Result := '';
end;

//-----------------------------------------------------------------------------
//  EnumChildWindowsのコールバック関数
//
//  この関数の呼び出し側でlParにウィンドウの情報構造体のポインタを渡している
//  取得したウィンドウハンドルをこの構造体のメンバーに代入して返す
//
//  無効化されているウィンドウ(DelphiではEnabledがFalseの場合)は，PtInRectは親
//  のウィンドウを取得してしまう
//  そこで更にこのコールバックの再帰処理で子ウィンドウを検索
//-----------------------------------------------------------------------------
function EnumChildWindowsProc(hWindow: hWnd; lPar: PWndInfo):
  Boolean; Stdcall;
var
  ARect : TRect;
  APos  : TPoint;
begin
  Result := True;

  //非表示のウィンドウは対象外
  if not IsWindowVisible(hWindow) then exit;

  //マウスカーソル位置のウィンドウのTRect構造体を取得
  APos  := Point(lPar^.pt.x, lPar^.pt.Y);
  GetWindowRect(hWindow, ARect);

  //APos(マウスカーソル)がTRectの矩形領域内にあれば
  //それが対象，または親のウィンドウ
  if PtInRect(ARect, APos) then begin
    //hWindowの子ウィンドウを調べて，なければhWindowが該当ウィンドウ
    EnumChildWindows(hWindow, @EnumChildWindowsProc, LPARAM(lPar));
    if lPar^.hWindow = 0 then begin
      lPar^.hWindow := hWindow;
      //検索終了
      Result := False;
    end;
  end;
end;

//=============================================================================
//  マウスカーソル下のウインドウの検出
//
//  WindowFromPointは無効化のウィンドウは検出しないのでEnumChildWindowsで子ウ
//  ィンドウを検索して調べる
//  マウスカーソルがあるウィンドウのタイトルとクラス名をEidt1に表示
//=============================================================================
procedure TMainForm.Button1Click(Sender: TObject);
var
  StartTime : DWORD;
  WndInfo   : TWndInfo;
  hwindow   : HWND;
begin
  Edit1.Text := '';

  //指定時間が経過したら検索開始
  Starttime := timeGetTime;
  while (timeGetTime - StartTime) < 3000 do begin
    Sleep(100);
    Application.ProcessMessages;
  end;

  //マウスカーソルの位置を取得
  GetCursorPos(WndInfo.pt);
  //マウスカーソル下のウィンドウハンドルを取得
  //WindowFromPointは無効化のウィンドウは検出しない
  hWindow := WindowFromPoint(WndInfo.pt);

  if hWindow <> 0 then begin
    //子ウィンドウの中から探す
    //見つかれば構造体のhWindowにウィンドウハンドル返す
    //見つからなけば元の0のまま
    WndInfo.hWindow := 0;
    EnumChildWindows(hWindow, @EnumChildWindowsProc, LPARAM(@WndInfo));
    //子ウィドウがないか全ての子ウィンドウの中になければ，自身が対象のウィンドウ
    if WndInfo.hWindow = 0 then WndInfo.hWindow := hWindow;

    if WndInfo.hWindow = Edit1.Handle then begin
      Edit1.Text := 'This is me !';
    end else begin
      Edit1.Text := GetWindowTitleStr(WndInfo.hWindow) + '   ' +
                    GetWindowClassNameStr(WndInfo.hWindow) ;
    end;
  end;
end;

end.

unit MainFormUnit;

interface

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

type
  TMainForm = class(TForm)
    Button1: TButton;
    Image1: TImage;
    procedure Button1Click(Sender: TObject);
  private
    { Private 宣言 }
  public
    { Public 宣言 }
  end;

var
  MainForm: TMainForm;

implementation

uses MMSystem;

{$R *.dfm}

//=============================================================================
//  マウスカーソルのキャプチャ
//  このフォーム上にTImageに描画
//=============================================================================
procedure TMainForm.Button1Click(Sender: TObject);
var
  StartTime   : DWORD;
  ACursorPos  : TPoint;
  ACursorInfo : TCursorInfo;
  AIconInfo   : TIconInfo;
begin
  //指定時間が経過したらキャプチャ開始
  Starttime := timeGetTime;
  while (timeGetTime - StartTime) < 3000 do begin
    Sleep(100);
    Application.ProcessMessages;
  end;

  //カーソルの位置を取得
  GetCursorPos(ACursorPos);
  ACursorInfo.cbSize := SizeOf(TCursorInfo);
  //現在のカーソルを指定
  ACursorInfo.flags  := CURSOR_SHOWING;
  //現在のマウスカーソルとアイコンとしての情報を取得
  //ユーザが独自に作成したカーソルもキャプチャ可能となる
  GetCursorInfo(ACursorInfo);
  GetIconInfo(ACursorInfo.hCursor, AIconInfo);

  //その情報を元に，Image1に描画する
  Image1.Picture.Assign(nil);
  DrawIconEx(Image1.Canvas.Handle,
             0,
             0,
             ACursorInfo.hCursor,
             0,
             0,
             0,
             0,
             DI_DEFAULTSIZE or DI_NORMAL);

  //AIconInfoが作成したビットマップを解放
  DeleteObject(AIconInfo.hbmMask);
  DeleteObject(AIconInfo.hbmColor);
end;

end.

unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    Button1: TButton;
    Image1: TImage;
    procedure Button1Click(Sender: TObject);
  private
    { Private 宣言 }
    procedure DrawMouseCursor(ACanvas: TCanvas; ALeft, ATop : Integer);
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

uses
  MMSystem;

{$R *.dfm}

//=============================================================================
//  マウスカーソルの影付きキャプチャ
//  このフォーム上のTImageに描画
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
var
  StartTime : DWORD;
begin
  Image1.Picture.Assign(nil);

  //指定時間が経過したらキャプチャ開始
  Starttime := timeGetTime;
  while (timeGetTime - StartTime) < 3000 do begin
    Sleep(100);
    Application.ProcessMessages;
  end;

  DrawMouseCursor(Image1.Canvas, 0, 0);
end;

//-----------------------------------------------------------------------------
//  マウスカーソルのマスク画像の処理専用(マウスカーソルの影部分)
//
//  与えられたビットマップのピクセル[0, 0]と同じ色のピクセルを透明化する
//  それ以外のピクセルは，透過度をOpadityで指定する値にする
//
//  ABitmap : 処理対象のビットマップ．処理したビットマップを返す
//-----------------------------------------------------------------------------
procedure ShadowMouseCursorBitmapToTransparent(ABitmap: TBitmap; Opacity: Byte);
type
  TRGBQArray = array [0..255] of RGBQUAD;
  PRGBQArray = ^TRGBQArray;
var
  LTransColor : TColor;
  LTransR     : Byte;
  LTransG     : Byte;
  LTransB     : Byte;
  LRed        : Byte;
  LGreen      : Byte;
  LBlue       : Byte;
  LYPos       : Integer;
  LXPos       : Integer;
  LScanArray  : PRGBQArray;
  LColorQuad  : RGBQUAD;
begin
  //32bitのビットマップにし，AlphaFormatの値を退避
  ABitmap.PixelFormat := pf32bit;
  ABitmap.AlphaFormat := afDefined;

  //指定色のR,G,Bの各値を取得しておく
  LTransColor := ABitmap.Canvas.Pixels[1, ABitmap.Height - 1];
  LTransR := GetRValue(LTransColor);
  LTransG := GetGValue(LTransColor);
  LTransB := GetBValue(LTransColor);

  for LYPos := 0 to ABitmap.Height - 1 do begin
    LScanArray := ABitmap.ScanLine[LYPos];

    for LXPos := 0 to ABitmap.Width - 1 do begin

      LRed   := LScanArray[LXPos].rgbRed;
      LGreen := LScanArray[LXPos].rgbGreen;
      LBlue  := LScanArray[LXPos].rgbBlue;

      if (LTransR = LRed) and (LTransG = LGreen) and (LTransB = LBlue) then begin
        LColorQuad.rgbBlue     := 0;
        LColorQuad.rgbGreen    := 0;
        LColorQuad.rgbRed      := 0;
        LColorQuad.rgbReserved := 0;
      end else begin
        LColorQuad.rgbRed      := LRed;
        LColorQuad.rgbGreen    := LGreen;
        LColorQuad.rgbBlue     := LBlue;
        LColorQuad.rgbReserved := Opacity;
      end;
      LScanArray[LXPos] := LColorQuad;
    end;
  end;
end;

//=============================================================================
//  ACanvasのTCanasにマウスカーソルを描画する
//=============================================================================
procedure TForm1.DrawMouseCursor(ACanvas: TCanvas; ALeft, ATop : Integer);
var
  LCursorPos  : TPoint;
  LCursorInfo : TCursorInfo;
  LbmpOrigin  : TBitmap;
  LbmpMask    : TBitmap;
begin
  //マウスカーソルを描画するビットマップ作成
  LbmpMask   := TBitmap.Create;
  LbmpOrigin := TBitmap.Create;
  try
    //アルファチャネルの処理をするので，AlphaFormat := afDefined;とする
    LbmpOrigin.PixelFormat := pf32bit;
    LbmpOrigin.AlphaFormat := afDefined;

    //カーソルサイズ取得
    LbmpOrigin.Width  := GetSystemMetrics(SM_CXCURSOR);
    LbmpOrigin.Height := GetSystemMetrics(SM_CYCURSOR);

    LbmpMask.Assign(LbmpOrigin);

    //カーソルの位置を取得して現在のカーソルを指定
    //現在のカーソルを指定するユーザ独自のカーソルもキャプチャ可能となる
    GetCursorPos(LCursorPos);
    LCursorInfo.cbSize := SizeOf(TCursorInfo);
    LCursorInfo.flags  := CURSOR_SHOWING;
    GetCursorInfo(LCursorInfo);

    //DI_MASKにしてマスク画像を取得してビットマップに描画
    DrawIconEx(LbmpMask.Canvas.Handle,
               0,
               0,
               LCursorInfo.hCursor,
               0,
               0,
               0,
               0,
               DI_MASK);
    //作成したビットマップを半透明にする
    ShadowMouseCursorBitmapToTransparent(LbmpMask, 50);

    //元のマウスカーソルの画像を取得
    DrawIconEx(LbmpOrigin.Canvas.Handle,
               ALeft,
               ATop,
               LCursorInfo.hCursor,
               0,
               0,
               0,
               0,
               DI_DEFAULTSIZE or DI_IMAGE);

    //目的のTCanvasに描画する
    //半透明化したマスク画像の上に元の画像を重ね描画する
    ACanvas.Draw(ALeft + 2, ATop + 1, LbmpMask);
    ACanvas.Draw(ALeft, ATop, LbmpOrigin);
  finally
    FreeAndNil(LbmpMask);
    FreeAndNil(LbmpOrigin);
    DeleteObject(LCursorInfo.hCursor);
  end;
end;

end.

unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    Button1: TButton;
    Image1: TImage;
    procedure Button1Click(Sender: TObject);
  private
    { Private 宣言 }
    procedure GaussianBlur(ASrcBmp, ADstBmp: TBitmap; ARadius, ARepeat: integer);
    procedure DrawMouseCursor(ACanvas: TCanvas; ALeft, ATop : Integer);
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

uses
  MMSystem;

{$R *.dfm}

//=============================================================================
//  マウスカーソルの影付きキャプチャ
//  このフォーム上のTImageに描画
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
var
  StartTime : DWORD;
begin
  Image1.Picture.Assign(nil);

  //指定時間が経過したらキャプチャ開始
  Starttime := timeGetTime;
  while (timeGetTime - StartTime) < 3000 do begin
    Sleep(100);
    Application.ProcessMessages;
  end;

  DrawMouseCursor(Image1.Canvas, 0, 0);
end;

//-----------------------------------------------------------------------------
//  マウスカーソルのマスク画像の処理専用(マウスカーソルの影部分)
//
//  与えられたビットマップのピクセル[0, 0]と同じ色のピクセルを透明化する
//  それ以外のピクセルは，透過度をOpadityで指定する値にする
//
//  ABitmap : 処理対象のビットマップ．処理したビットマップを返す
//-----------------------------------------------------------------------------
procedure ShadowMouseCursorBitmapToTransparent(ABitmap: TBitmap; Opacity: Byte);
type
  TRGBQArray = array [0..255] of RGBQUAD;
  PRGBQArray = ^TRGBQArray;
var
  LTransColor : TColor;
  LTransR     : Byte;
  LTransG     : Byte;
  LTransB     : Byte;
  LRed        : Byte;
  LGreen      : Byte;
  LBlue       : Byte;
  LYPos       : Integer;
  LXPos       : Integer;
  LScanArray  : PRGBQArray;
  LColorQuad  : RGBQUAD;
begin
  //32bitのビットマップにし，AlphaFormatの値を退避
  ABitmap.PixelFormat := pf32bit;
  ABitmap.AlphaFormat := afDefined;

  //指定色のR,G,Bの各値を取得しておく
  LTransColor := ABitmap.Canvas.Pixels[1, ABitmap.Height - 1];
  LTransR := GetRValue(LTransColor);
  LTransG := GetGValue(LTransColor);
  LTransB := GetBValue(LTransColor);

  for LYPos := 0 to ABitmap.Height - 1 do begin
    LScanArray := ABitmap.ScanLine[LYPos];

    for LXPos := 0 to ABitmap.Width - 1 do begin

      LRed   := LScanArray[LXPos].rgbRed;
      LGreen := LScanArray[LXPos].rgbGreen;
      LBlue  := LScanArray[LXPos].rgbBlue;

      if (LTransR = LRed) and (LTransG = LGreen) and (LTransB = LBlue) then begin
        LColorQuad.rgbBlue     := 0;
        LColorQuad.rgbGreen    := 0;
        LColorQuad.rgbRed      := 0;
        LColorQuad.rgbReserved := 0;
      end else begin
        LColorQuad.rgbRed      := LRed;
        LColorQuad.rgbGreen    := LGreen;
        LColorQuad.rgbBlue     := LBlue;
        LColorQuad.rgbReserved := Opacity;
      end;
      LScanArray[LXPos] := LColorQuad;
    end;
  end;
end;

//=============================================================================
//  ACanvasのTCanasにマウスカーソルを描画する
//=============================================================================
procedure TForm1.DrawMouseCursor(ACanvas: TCanvas; ALeft, ATop : Integer);
var
  LCursorPos   : TPoint;
  LCursorInfo  : TCursorInfo;
  LbmpOrigin   : TBitmap;
  LbmpMask     : TBitmap;
  LbmpMaskBlur : TBitmap;
begin
  //マウスカーソルを描画するビットマップ作成
  LbmpMask   := TBitmap.Create;
  LbmpMaskBlur := TBitmap.Create;
  LbmpOrigin := TBitmap.Create;
  try
    //アルファチャネルの処理をするので，AlphaFormat := afDefined;とする
    LbmpOrigin.PixelFormat := pf32bit;
    LbmpOrigin.AlphaFormat := afDefined;

    //カーソルサイズ取得
    LbmpOrigin.Width  := GetSystemMetrics(SM_CXCURSOR);
    LbmpOrigin.Height := GetSystemMetrics(SM_CYCURSOR);

    LbmpMask.Assign(LbmpOrigin);

    //カーソルの位置を取得して現在のカーソルを指定
    //現在のカーソルを指定するユーザ独自のカーソルもキャプチャ可能となる
    GetCursorPos(LCursorPos);
    LCursorInfo.cbSize := SizeOf(TCursorInfo);
    LCursorInfo.flags  := CURSOR_SHOWING;
    GetCursorInfo(LCursorInfo);

    //DI_MASKにしてマスク画像を取得してビットマップに描画
    DrawIconEx(LbmpMask.Canvas.Handle,
               0,
               0,
               LCursorInfo.hCursor,
               0,
               0,
               0,
               0,
               DI_MASK);
    //作成したビットマップを半透明にしてガウスぼかしを実行
    ShadowMouseCursorBitmapToTransparent(LbmpMask, 75);
    GaussianBlur(LbmpMask, LbmpMaskBlur, 1, 1);

    //元のマウスカーソルの画像を取得
    DrawIconEx(LbmpOrigin.Canvas.Handle,
               ALeft,
               ATop,
               LCursorInfo.hCursor,
               0,
               0,
               0,
               0,
               DI_DEFAULTSIZE or DI_IMAGE);

    //目的のTCanvasに描画する
    //半透明化したマスク画像の上に元の画像を重ね描画する
    ACanvas.Draw(ALeft + 2, ATop + 1, LbmpMaskBlur);
    ACanvas.Draw(ALeft, ATop, LbmpOrigin);
  finally
    FreeAndNil(LbmpMask);
    FreeAndNil(LbmpMaskBlur);
    FreeAndNil(LbmpOrigin);
    DeleteObject(LCursorInfo.hCursor);
  end;
end;

//-----------------------------------------------------------------------------
//  最初の引数のTBitmapのガウスぼかし画像を作成する関数
//  戻り値は第2引数のTBitmap
//-----------------------------------------------------------------------------
procedure TForm1.GaussianBlur(ASrcBmp, ADstBmp: TBitmap; ARadius,
  ARepeat: integer);
type
  TRGBQuadArray = array [0..MaxInt div SizeOf(TRGBQuad) - 1] of TRGBQuad;
  PRGBQuadArray = ^TRGBQuadArray;
var
  LYRepeatCnt  : Integer;
  LXRepeatCnt  : Integer;
  LDiameter    : Integer;
  LImgWidth    : Integer;
  LImgHeight   : Integer;
  LPosX        : Integer;
  LPosY        : Integer;
  LPixel1      : Integer;
  LPixel2      : Integer;
  LCalcX       : Integer;
  LCalcY       : Integer;
  LScanLineDst : PRGBQuadArray;
  LpARGB       : PRGBQuad;
  LAlpha       : array of Integer;
  LRed         : array of Integer;
  LGreen       : array of Integer;
  LBlue        : array of Integer;
  LScanStart   : Integer;
  LDistance    : Integer;
  LBytesShift  : Integer;
begin
  ADstBmp.Assign(ASrcBmp);
  if ARadius = 0 then exit;

  LDiameter  := (ARadius * 2) + 1;
  if ASrcBmp.PixelFormat = pf32bit then begin
    LBytesShift := SizeOf(TRGBQuad);
  end else begin
    LBytesShift := SizeOf(TRGBTriple);
  end;

  LImgWidth  := ADstBmp.Width - 1;
  LImgHeight := ADstBmp.Height - 1;

  //計算範囲を(幅x半径x2+1)に拡張
  SetLength(LAlpha, LImgWidth + 1 + (ARadius * 2));
  SetLength(LRed,   LImgWidth + 1 + (ARadius * 2));
  SetLength(LGreen, LImgWidth + 1 + (ARadius * 2));
  SetLength(LBlue,  LImgWidth + 1 + (ARadius * 2));

  LScanLineDst := ADstBmp.ScanLine[0];
  LDistance    := integer(ADstBmp.ScanLine[1]) - integer(LScanLineDst);

  LScanStart := Integer(LScanLineDst);
//  ShowMessage(IntToSTr(LDistance) + sLineBreak + IntToStr(LScanStart));

  for LPosY := 0 to LImgHeight do begin
    for LYRepeatCnt := 1 to ARepeat do begin
      LXRepeatCnt := -ARadius;
      while LXRepeatCnt <= LImgWidth + ARadius do begin
        LCalcX := LXRepeatCnt;
        if LCalcX < 0 then begin
          LCalcX := 0;
        end else
        if LCalcX >= LImgWidth then begin
          LCalcX := LImgWidth;
        end;

        LpARGB  := PRGBQuad(LScanStart + LCalcX * LBytesShift);
        LPixel1 := LXRepeatCnt + ARadius;
        LPixel2 := LXRepeatCnt + ARadius - 1;

        LAlpha[LPixel1] := LpARGB^.rgbReserved + LAlpha[LPixel2];
        LRed  [LPixel1] := LpARGB^.rgbRed      + LRed  [LPixel2];
        LGreen[LPixel1] := LpARGB^.rgbGreen    + LGreen[LPixel2];
        LBlue [LPixel1] := LpARGB^.rgbBlue     + LBlue [LPixel2];

        inc(LXRepeatCnt);
      end;

      for LPosX := 0 to LImgWidth do begin
        LpARGB  := PRGBQuad(LScanStart + LPosX * LBytesShift);
        LCalcX  := LPosX + ARadius;
        LPixel1 := LCalcX + ARadius;
        LPixel2 := LCalcX - 1 - ARadius;

        LpARGB^.rgbReserved := ((LAlpha[LPixel1] - LAlpha[LPixel2]) div LDiameter);
        LpARGB^.rgbRed      := ((LRed  [LPixel1] - LRed  [LPixel2]) div LDiameter);
        LpARGB^.rgbGreen    := ((LGreen[LPixel1] - LGreen[LPixel2]) div LDiameter);
        LpARGB^.rgbBlue     := ((LBlue [LPixel1] - LBlue [LPixel2]) div LDiameter);
      end;
    end;
    inc(LScanStart, LDistance);
  end;


  //計算範囲を(高さx半径x2+1)に拡張
  SetLength(LAlpha, LImgHeight + 1 + (ARadius * 2));
  SetLength(LRed,   LImgHeight + 1 + (ARadius * 2));
  SetLength(LGreen, LImgHeight + 1 + (ARadius * 2));
  SetLength(LBlue,  LImgHeight + 1 + (ARadius * 2));

  for LPosX := 0 to LImgWidth do begin
    for LYRepeatCnt := 1 to ARepeat do begin
      LScanStart  := Integer(LScanLineDst);
      LXRepeatCnt := -ARadius;
      while LXRepeatCnt <= LImgHeight + ARadius do begin
        if (LXRepeatCnt > 0) and (LXRepeatCnt < LImgHeight) then begin
          inc(LScanStart, LDistance);
        end;

        LpARGB  := PRGBQuad(LScanStart + LPosX * LBytesShift);
        LPixel1 := LXRepeatCnt + ARadius;
        LPixel2 := LXRepeatCnt + ARadius - 1;

        LAlpha[LPixel1] := LpARGB.rgbReserved + LAlpha[LPixel2];
        LRed  [LPixel1] := LpARGB.rgbRed      + LRed  [LPixel2];
        LGreen[LPixel1] := LpARGB.rgbGreen    + LGreen[LPixel2];
        LBlue [LPixel1] := LpARGB.rgbBlue     + LBlue [LPixel2];

        inc(LXRepeatCnt);
      end;

      LScanStart := Integer(LScanLineDst);
      for LPosY := 0 to LImgHeight do begin
        LpARGB  := PRGBQuad(LScanStart + LPosX * LBytesShift);
        LCalcY  := LPosY + ARadius;
        LPixel1 := LCalcY + ARadius;
        LPixel2 := LCalcY - 1 - ARadius;

        LpARGB.rgbReserved := ((LAlpha[LPixel1] - LAlpha[LPixel2]) div LDiameter);
        LpARGB.rgbRed      := ((LRed  [LPixel1] - LRed  [LPixel2]) div LDiameter);
        LpARGB.rgbGreen    := ((LGreen[LPixel1] - LGreen[LPixel2]) div LDiameter);
        LpARGB.rgbBlue     := ((LBlue [LPixel1] - LBlue [LPixel2]) div LDiameter);

        inc(LScanStart, LDistance);
      end;
    end;
  end;

  SetLength(LAlpha, 0);
  SetLength(LRed, 0);
  SetLength(LGreen, 0);
  SetLength(LBlue, 0);
end;

end.

unit MainFormUnit;

interface

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

type
  TMainForm = class(TForm)
    CheckBox1: TCheckBox;
    ListBox1: TListBox;
    Image1: TImage;
    procedure FormCreate(Sender: TObject);
    procedure FormShow(Sender: TObject);
    procedure CheckBox1Click(Sender: TObject);
    procedure ListBox1Click(Sender: TObject);
  private
    { Private 宣言 }
  public
    { Public 宣言 }
  end;

var
  MainForm: TMainForm;

implementation

{$R *.dfm}

// ============================================================================
//  フォーム生成時の処理
//  使用可能なシステム関係のマウスポインタ名を列挙
// ============================================================================
procedure TMainForm.FormCreate(Sender: TObject);
var
  LCursorNo : Integer;
  LhCursor  : HCURSOR;
  LIdString : string;
begin
  ListBox1.Items.BeginUpdate;
  ListBox1.Items.Clear;

  //HCURSORはHICONでもよい
  for LCursorNo := -1 downto -22 do begin
    LhCursor := TCursor(LCursorNo);
    if LhCursor <> 0 then begin
      CursorToIdent(LhCursor, LIdString);
      if LIdString <> '' then begin
        ListBox1.Items.Add(LIdString);
      end;
    end;
  end;
  ListBox1.Items.EndUpdate;
end;

// ============================================================================
//  フォームの表示開始時の処理
//  システムが現在[マウスポインタの下に影を表示する]設定になっているかを調べる
//
//  SPI_GETCURSORSHADOWはTForm.OnCreateで実行すると例外が発生するので注意
//  マウスポインタの列挙のコードを実行しなければOnCreateでも取得可能
// ============================================================================
procedure TMainForm.FormShow(Sender: TObject);
var
  LHasDropShadow : Boolean;
begin
  SystemParametersInfo(SPI_GETCURSORSHADOW, 0, @LHasDropShadow, 0);
  CheckBox1.Checked := LHasDropShadow;
end;

// ============================================================================
//  CheckBox1のClickイベント処理
//  マウスポインタの下影の表示．非表示の切り換え
//
//  マウスポインタ(マウスカーソル)によっては影を表示しないものもある
// ============================================================================
procedure TMainForm.CheckBox1Click(Sender: TObject);
var
  LFlag : Boolean;
begin
  LFlag := CheckBox1.Checked;
  SystemParametersInfo(SPI_SETCURSORSHADOW, 0, Pointer(LFlag), 0);
end;

// ============================================================================
//  ListBox1のOnClickイベント
// ============================================================================
procedure TMainForm.ListBox1Click(Sender: TObject);
var
  LListItem   : Integer;
  LhCursor    : HCURSOR;
  LCursorInfo : TCursorInfo;
begin
  LListItem := ListBox1.ItemIndex;
  if LListItem < 0 then exit;

  Image1.Picture.Assign(nil);
  //選択したカーソルの名前からカーソルのハンドルを取得
  LhCursor := StringToCursor(ListBox1.Items[LListItem]);

  //カーソルを変更
  Screen.Cursor := LhCursor;

  //現在のカーソルの情報を取得してTImageにカーソル画像を描画
  LCursorInfo.cbSize := SizeOf(TCursorInfo);
  LCursorInfo.flags  := 0;//CURSOR_SHOWING;
  GetCursorInfo(LCursorInfo);
  DrawIconEx(Image1.Canvas.Handle,
             0,
             0,
             LCursorInfo.hCursor,
             0,
             0,
             0,
             0,
             DI_DEFAULTSIZE or DI_NORMAL);
end;

end.

procedure TMainForm.ListBox1Click(Sender: TObject);
var
  LListItem : Integer;
  LhCursor  : HCURSOR;
begin
  LListItem := ListBox1.ItemIndex;
  if LListItem < 0 then exit;

  Image1.Picture.Assign(nil);
  //選択したカーソルの名前からカーソルのハンドルを取得
  LhCursor := StringToCursor(ListBox1.Items[LListItem]);

  //カーソルを変更
  Screen.Cursor := LhCursor;

  //現在のカーソルのハンドルを取得
  LhCursor := Windows.GetCursor;
  try
    DrawIconEx(Image1.Canvas.Handle,
               0,
               0,
               LhCursor,
               0,
               0,
               0,
               0,
               DI_DEFAULTSIZE or DI_NORMAL);
  finally
    DestroyCursor(LhCursor);
  end;
end;

procedure TMainForm.ListBox1Click(Sender: TObject);
var
  LListItem : Integer;
  LhCursor  : HCURSOR;
begin
  LListItem := ListBox1.ItemIndex;
  if LListItem < 0 then exit;

  Image1.Picture.Assign(nil);
  //選択したカーソルの名前からカーソルのハンドルを取得
  LhCursor := StringToCursor(ListBox1.Items[LListItem]);

  //カーソルを変更
  Screen.Cursor := LhCursor;

  //現在のカーソルのハンドルを取得
  LhCursor := Windows.GetCursor;
  try
    DrawIcon(Image1.Canvas.Handle, 0, 0, LhCursor);
  finally
    DestroyCursor(LhCursor);
  end;
end;

unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    Button1: TButton;
    procedure Button1Click(Sender: TObject);
  private
    { Private 宣言 }
    procedure PreviewCaptureImage(ABitmap: TBitmap);
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

uses
  FormCaptureImageUnit;

{$R *.dfm}

//=============================================================================
//  キャプチャー開始ボタン
//  このボタンクリック後，指定時間後にキャプチャー
//
//  このプロジェクトはApplication.MainFormOnTaskbar := False;としている
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);

//CAPTUREBLTは少なくともDelphi XE以前にはないので定義
const
  CAPTUREBLT = $40000000;
var
  LhTarget      : HWND;
  LTargetLeft   : Integer;
  LTargetTop    : Integer;
  LTargetRight  : Integer;
  LTargetBottom : Integer;
  LScreenDC     : HDC;
  LRectTarget   : TRect;
  LbmpOrigin    : TBitmap;
  LCursorPos    : TPoint;
  LCursorInfo   : TCursorInfo;
  LIconInfo     : TIconInfo;
begin
  //指定時間経過後にキャプチャ開始
  //この時間内に他のウィンドウをアクティブにすれば，そのウィンドウをキャプチャ
  Sleep(1000);


  //キャプチャするウィンドウは，現在アクティブなウィンドウとする
  LhTarget := Windows.GetForegroundWindow;

  if CheckWin32Version(6, 0) then begin
    //拡張したウィンドウのフレームのTRect構造体の値を取得
    DwmGetWindowAttribute(LhTarget,
                          DWMWA_EXTENDED_FRAME_BOUNDS,
                          @LRectTarget,
                          SizeOf(TRect));
  end else begin
    GetWindowRect(LhTarget, LRectTarget);
  end;

  LTargetLeft   := LRectTarget.Left;
  LTargetTop    := LRectTarget.Top;
  LTargetRight  := LRectTarget.Right;
  LTargetBottom := LRectTarget.Bottom;

  //キャプチャーした画像を格納するビットマップを作成
  LbmpOrigin             := TBitmap.Create;
  LbmpOrigin.PixelFormat := pf32bit;
  LbmpOrigin.Width       := LTargetRight  - LTargetLeft;
  LbmpOrigin.Height      := LTargetBottom - LTargetTop;

  try
    //デスクトップのデバイスコンテキスを取得
    LScreenDC := CreateDC('DISPLAY', nil, nil, nil);
    try
      //キャプチャー範囲をbmpOriginにBitBlt
      BitBlt(LbmpOrigin.Canvas.Handle,
             0,
             0,
             LTargetRight  - LTargetLeft,
             LTargetBottom - LTargetTop,
             LScreenDC,
             LTargetLeft,
             LTargetTop,
             SRCCOPY or CAPTUREBLT);
    finally
      DeleteDC(LScreenDC);
    end;

    //-----  マウスカーソルをキャプチャーするためのコード ---------------------

    //カーソルの位置を取得
    GetCursorPos(LCursorPos);
    LCursorInfo.cbSize := SizeOf(TCursorInfo);
    //見えているマウスカーソル
    LCursorInfo.flags  := CURSOR_SHOWING;
    //現在のマウスカーソルの，アイコンとしての情報を取得
    GetCursorInfo(LCursorInfo);
    GetIconInfo(LCursorInfo.hCursor, LIconInfo);

    //その情報を元に，キャプチャーしたビットマップに重ね描画する
    DrawIconEx(LbmpOrigin.Canvas.Handle,
               LCursorPos.X - LTargetLeft - Integer(LIconInfo.xHotspot),
               LCursorPos.y - LTargetTop  - Integer(LIconInfo.yHotspot),
               LCursorInfo.hCursor,
               0,
               0,
               0,
               0,
               DI_DEFAULTSIZE or DI_NORMAL);

    //-----  ここまで ---------------------------------------------------------

    //ビットマップ表示用のフォームを生成して表示
    PreviewCaptureImage(LbmpOrigin);
  finally
    FreeAndNil(LbmpOrigin);
  end;
end;

//=============================================================================
//  キャプチャした画像をプレビュー表示するメソッド
//  Imaage1のサイズを設定して描画する場合は，Image1.AutoSizeの値をFalseにする
//=============================================================================
procedure TForm1.PreviewCaptureImage(ABitmap: TBitmap);
begin
  //追加描画可能なように代入とする.Assignだと追加描画は不可
  FormCaptureImage.Image1.Picture.Graphic := nil;
  FormCaptureImage.Image1.Picture.Bitmap  := ABitmap;

  //キャプチャーしたビットマップを表示
  FormCaptureImage.Show;
end;

end.

unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    Button1: TButton;
    PopupMenu1: TPopupMenu;
    Timer1: TTimer;
    procedure Button1Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure Timer1Timer(Sender: TObject);
  private
    { Private 宣言 }
    FStartTime    : DWORD;
    FhTarget      : HWND;
    //キャプチャー範囲の各値
    FTargetLeft   : Integer;
    FTargetTop    : Integer;
    FTargetRight  : Integer;
    FTargetBottom : Integer;

    FdropShadowSize : Integer;
    procedure CaptuerWindowRect(hWindow: HWND);
    procedure PreviewCaptureImage(ABitmap: TBitmap);
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

uses
  FormCaptureImageUnit,
  MMSystem, Math;

{$R *.dfm}

//-----------------------------------------------------------------------------
//  EnumWindowsのコールバック関数
//  ポップアップメニューやツールチップ等のハンドルを取得して，そのハンドルから
//  キャプチャーする範囲を再計算
//  ボップアップメニュー等のウィンドウはZオーダーのトップであることを利用
//-----------------------------------------------------------------------------
function EnumWindowProc(hWindow: hWnd; lPalam: Integer): Boolean; Stdcall;
var
  LRect : TRect;
begin
  Result := True;
  if not IsWindowVisible(hWindow) then exit;

  //Zオーダーで一番上のウインドウを取得
  if GetWindow(Form1.FhTarget, GW_HWNDFIRST) = hWindow then begin
    //そのウィンドウの位置を取得
    GetWindowRect(hWindow, LRect);
    //影の部分(drop Shadow)のサイズを加える
    LRect.Right  := LRect.Right  + Form1.FdropShadowSize;
    LRect.Bottom := LRect.Bottom + Form1.FdropShadowSize;

    //キャプチャーする領域を調整
    Form1.FTargetLeft   := Min(LRect.Left,   Form1.FTargetLeft);
    Form1.FTargetTop    := Min(LRect.Top,    Form1.FTargetTop);
    Form1.FTargetRight  := Max(LRect.Right,  Form1.FTargetRight);
    Form1.FTargetBottom := Max(LRect.Bottom, Form1.FTargetBottom);

    Result := False;
  end;
end;

//=============================================================================
//  フォーム生成時の処理
//=============================================================================
procedure TForm1.FormCreate(Sender: TObject);

  //---------------------------------------------------------------------------
  procedure AddPopupMeneItem(strItem: String);
  var
    LItem : TMenuItem;
  begin
    LItem := TMenuItem.Create(Self);
    LItem.Caption := strItem;
    PopupMenu1.Items.Add(LItem);
  end;
  //---------------------------------------------------------------------------

begin
  Self.Hint     := 'キャプチャのテスト';
  Self.ShowHint := True;

  Timer1.Enabled := False;

  Self.PopupMenu := PopupMenu1;
  //ポップアップのメニュー作成
  AddPopupMeneItem('TEST 100');
  AddPopupMeneItem('TEST 110');
  AddPopupMeneItem('TEST 120');
  AddPopupMeneItem('TEST 130');
  AddPopupMeneItem('TEST 140');
  AddPopupMeneItem('TEST 150');

  //影のサイズ(標準では3)
  FdropShadowSize := 0;
end;

//=============================================================================
//  タイマー起動
//  ポップアップメニューを表示中にキャプチャーボタンをクリックすると，ポップ
//  アップメニューは閉じてしまうので，タイマー起動中にポップアップメニューを
//  表示してキャプチャーするようにする
//  Sleep関数では，このようなことはできない
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
begin
  FStartTime := timeGetTime;
  Timer1.Enabled := True;
end;

//=============================================================================
//  タイマーイベント
//  指定時間がきたらタイマーを止めてキャプチャー開始
//=============================================================================
procedure TForm1.Timer1Timer(Sender: TObject);
begin
  if (timeGetTime - FStartTime) >= 3000 then begin
    Timer1.Enabled := False;
    CaptuerWindowRect(GetForegroundWindow);
  end;
end;

//-----------------------------------------------------------------------------
//  実際にキャプチャーを実行するコード
//
//  このプロジェクトはApplication.MainFormOnTaskbar := False;としている
//-----------------------------------------------------------------------------
procedure TForm1.CaptuerWindowRect(hWindow: HWND);

//CAPTUREBLTは少なくともDelphi XE以前にはないので定義
const
  CAPTUREBLT = $40000000;
var
  LBackForm   : TForm;
  LColorBack  : TColor;
  LScreenDC   : HDC;
  LRectTarget : TRect;
  LbmpOrigin  : TBitmap;
  LCursorPos  : TPoint;
  LCursorInfo : TCursorInfo;
  LIconInfo   : TIconInfo;
begin
  //キャプチャするウィンドウは，引数の値とする
  FhTarget := hWindow;

  if CheckWin32Version(6, 0) then begin
    //拡張したウィンドウのフレームのTRect構造体の値を取得
    DwmGetWindowAttribute(FhTarget,
                          DWMWA_EXTENDED_FRAME_BOUNDS,
                          @LRectTarget,
                          SizeOf(TRect));
  end else begin
    GetWindowRect(FhTarget, LRectTarget);
  end;

  FTargetLeft   := LRectTarget.Left;
  FTargetTop    := LRectTarget.Top;
  FTargetRight  := LRectTarget.Right;
  FTargetBottom := LRectTarget.Bottom;

  //ポップアップメニュー等を調べて，修正したキャプチャの矩形領域を取得
  //TargetLeft等に新しい値が格納される
  EnumWindows(@EnumWindowProc, 0);

  //キャプチャーした画像を格納するビットマップを作成
  LbmpOrigin             := TBitmap.Create;
  LbmpOrigin.PixelFormat := pf32bit;
  LbmpOrigin.Width       := FTargetRight  - FTargetLeft;
  LbmpOrigin.Height      := FTargetBottom - FTargetTop;

 try
    //BackFormは背景用のフォーム
    //デスクトップ等，他を背景にする場合は，このBackFormを使用しない
    LBackForm := TForm.Create(Self);
    try
      //背景色
      LColorBack            := clBlue;
      LBackForm.Position    := poDesigned;
      LBackForm.BorderStyle := bsNone;
      //そのサイズと位置をキャプチャーする範囲の値と合わせる
      LBackForm.SetBounds(FTargetLeft,
                          FTargetTop,
                          FTargetRight  - FTargetLeft,
                          FTargetBottom - FTargetTop);
      //背景色で塗り潰す
      LBackForm.Color := LColorBack;
      //表示する
      LBackForm.Show;
      UpdateWindow(LBackForm.Handle);
      Sleep(10);

      //その上に目的のウィンドウを表示する
      SetForegroundWindow(FhTarget);
      UpdateWindow(FhTarget);

      //デスクトップのデバイスコンテキスを取得
      LScreenDC := CreateDC('DISPLAY', nil, nil, nil);
      try
        //キャプチャー範囲をbmpOriginにBitBlt
        BitBlt(LbmpOrigin.Canvas.Handle,
               0,
               0,
               FTargetRight  - FTargetLeft,
               FTargetBottom - FTargetTop,
               LScreenDC,
               FTargetLeft,
               FTargetTop,
               SRCCOPY or CAPTUREBLT);
      finally
        DeleteDC(LScreenDC);
      end;
    finally
      FreeAndNil(LBackForm);
    end;

    //-----  マウスカーソルをキャプチャーするためのコード ---------------------

    //カーソルの位置を取得
    GetCursorPos(LCursorPos);
    LCursorInfo.cbSize := SizeOf(TCursorInfo);
    //見えているマウスカーソル
    LCursorInfo.flags  := CURSOR_SHOWING;
    //現在のマウスカーソルの，アイコンとしての情報を取得
    GetCursorInfo(LCursorInfo);
    GetIconInfo(LCursorInfo.hCursor, LIconInfo);

    //その情報を元に，キャプチャーしたビットマップに重ね描画する
    DrawIconEx(LbmpOrigin.Canvas.Handle,
               LCursorPos.X - FTargetLeft - Integer(LIconInfo.xHotspot),
               LCursorPos.y - FTargetTop  - Integer(LIconInfo.yHotspot),
               LCursorInfo.hCursor,
               0,
               0,
               0,
               0,
               DI_DEFAULTSIZE or DI_NORMAL);

    //-----  ここまで ---------------------------------------------------------

    //ビットマップ表示用のフォームを生成して表示
    PreviewCaptureImage(LbmpOrigin);
  finally
    FreeAndNil(LbmpOrigin);
  end;
end;

//-----------------------------------------------------------------------------
//  キャプチャした画像をプレビュー表示するメソッド
//  Imaage1のサイズを設定して描画する場合は，Image1.AutoSizeの値をFalseにする
//-----------------------------------------------------------------------------
procedure TForm1.PreviewCaptureImage(ABitmap: TBitmap);
begin
  //追加描画可能なように代入とする.Assignだと追加描画は不可
  FormCaptureImage.Image1.Picture.Graphic := nil;
  FormCaptureImage.Image1.Picture.Bitmap  := ABitmap;
  //キャプチャーしたビットマップを表示
  FormCaptureImage.Show;
end;

end.

  //[ウィンドウの下に影を表示する]になっている場合
  dropShadowSize := 3;

  if CheckWin32Version(6, 0) then begin
    TargetLeft   := RectTarget.Left   - 11;
    TargetTop    := RectTarget.Top    - 11;
    TargetRight  := RectTarget.Right  + 16;
    TargetBottom := RectTarget.Bottom + 18;
  end else begin
    TargetLeft   := RectTarget.Left;
    TargetTop    := RectTarget.Top;
    TargetRight  := RectTarget.Right;
    TargetBottom := RectTarget.Bottom;
  end;

//=============================================================================
//  Form2を表示
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
begin
  Form2.ShowModal;
end;

unit Unit2;

interface

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

type
  TForm2 = class(TForm)
    Button1: TButton;
    CheckBox1: TCheckBox;
    procedure Button1Click(Sender: TObject);
  private
    { Private 宣言 }
    hTarget      : HWND;
    PIDTarget    : Cardinal;
    //キャプチャー範囲の各値
    TargetLeft   : Integer;
    TargetTop    : Integer;
    TargetRight  : Integer;
    TargetBottom : Integer;
    procedure PreviewCaptureImage(ABitmap: TBitmap);
  public
    { Public 宣言 }
  end;

var
  Form2: TForm2;

implementation

uses FormCaptureImageUnit, Math, Unit1;

{$R *.dfm}

//-----------------------------------------------------------------------------
//  Windows Vista以降では，フォームのフレームの仕様が拡張されている
//  これを考慮したウィンドウのTRect構造体の値を取得
//-----------------------------------------------------------------------------
function GetWindowRectForVista(hWindow: HWND): TRect;
var
  ARect : TRect;
begin
  //Windows Vista以降は拡張フレーム
  if CheckWin32Version(6, 0) then begin
    //拡張したウィンドウのフレームのTRect構造体の値を取得
    DwmGetWindowAttribute(hWindow,
                          DWMWA_EXTENDED_FRAME_BOUNDS,
                          @ARect,
                          SizeOf(TRect));
  end else begin
    GetWindowRect(hWindow, ARect);
  end;
  Result := ARect;
end;

//-----------------------------------------------------------------------------
//  EnumWindowsのコールバック関数
//  hWindowと同じプロセスで起動しているウィンドウを調べて，キャプチャー範囲に
//  含める
//-----------------------------------------------------------------------------
function EnumWindowProc(hWindow: hWnd; lPalam: Integer): Boolean; Stdcall;
var
  PID   : Cardinal;
  ARect : TRect;
begin
  Result := True;

  if (IsWindowVisible(hWindow)) then begin
    //プロセスIDを調べて同じなら...
    GetWindowThreadProcessId(hWindow, @PID);
    if (PID = Form2.PIDTarget) and (hWindow <> Form2.hTarget) then begin

      //そのウィンドウのサイズを取得
      ARect := GetWindowRectForVista(hWindow);

      //キャプチャーする領域を調整
      Form2.TargetLeft   := Min(ARect.Left,   Form2.TargetLeft);
      Form2.TargetTop    := Min(ARect.Top,    Form2.TargetTop);
      Form2.TargetRight  := Max(ARect.Right,  Form2.TargetRight);
      Form2.TargetBottom := Max(ARect.Bottom, Form2.TargetBottom);
    end;
  end;
end;

//=============================================================================
//  今表示しているウィンドウを表示したウィンドウ(フォーム)も同時にキャプチャー
//  ただし，同じプロセス内のものに限る(システムのダイアログ等は不可)
//=============================================================================
procedure TForm2.Button1Click(Sender: TObject);

//CAPTUREBLTは少なくともDelphi XE以前にはないので定義
const
  CAPTUREBLT = $40000000;
var
  ScreenDC    : HDC;
  RectTarget  : TRect;
  bmpOrigin   : TBitmap;
  ACursorPos  : TPoint;
  ACursorInfo : TCursorInfo;
  AIconInfo   : TIconInfo;
begin
  //3秒間待つので，その間に他のウィンドウをアクティブにすればキャプチャーできる
  Sleep(3000);
  hTarget := GetForegroundWindow;

  //テストで他のウィンドウ等を操作する場合の対応策
  TargetLeft   := 0;
  TargetTop    := 0;
  TargetRight  := 0;
  TargetBottom := 0;

  //ウィンドウのサイズを取得
  RectTarget := GetWindowRectForVista(hTarget);

  TargetLeft   := RectTarget.Left;
  TargetTop    := RectTarget.Top;
  TargetRight  := RectTarget.Right;
  TargetBottom := RectTarget.Bottom;

  //現在のプロセスIDを取得
  GetWindowThreadProcessId(hTarget, @PIDTarget);
  //親ウィンドウを調べて，キャプチャー範囲を調整
  if CheckBox1.Checked then EnumWindows(@EnumWindowProc, 0);

  //キャプチャーした画像を格納するビットマップを作成
  bmpOrigin             := TBitmap.Create;
  bmpOrigin.PixelFormat := pf32bit;
  bmpOrigin.Width       := TargetRight  - TargetLeft;
  bmpOrigin.Height      := TargetBottom - TargetTop;

  bmpOrigin.Canvas.Brush.Color := clBlue;
  bmpOrigin.Canvas.FillRect(bmpOrigin.Canvas.ClipRect);

  try
    //デスクトップのデバイスコンテキスを取得
    ScreenDC := CreateDC('DISPLAY', nil, nil, nil);
    try
      //キャプチャー範囲をbmpOriginにBitBlt
      BitBlt(bmpOrigin.Canvas.Handle,
             0,
             0,
             TargetRight  - TargetLeft,
             TargetBottom - TargetTop,
             ScreenDC,
             TargetLeft,
             TargetTop,
             SRCCOPY or CAPTUREBLT);
    finally
      DeleteDC(ScreenDC);
    end;

    //-----  マウスカーソルをキャプチャーするためのコード ---------------------

    //カーソルの位置を取得
    GetCursorPos(ACursorPos);
    ACursorInfo.cbSize := SizeOf(TCursorInfo);
    //見えているマウスカーソル
    ACursorInfo.flags  := CURSOR_SHOWING;
    //現在のマウスカーソルの，アイコンとしての情報を取得
    GetCursorInfo(ACursorInfo);
    GetIconInfo(ACursorInfo.hCursor, AIconInfo);

    //その情報を元に，キャプチャーしたビットマップに重ね描画する
    DrawIconEx(bmpOrigin.Canvas.Handle,
               ACursorPos.X - TargetLeft - Integer(AIconInfo.xHotspot),
               ACursorPos.y - TargetTop  - Integer(AIconInfo.yHotspot),
               ACursorInfo.hCursor,
               0,
               0,
               0,
               0,
               DI_DEFAULTSIZE or DI_NORMAL);

    //-----  ここまで ---------------------------------------------------------

    //ビットマップ表示用のフォームを生成して表示
    PreviewCaptureImage(bmpOrigin);
  finally
    FreeAndNil(bmpOrigin);
  end;
end;

//=============================================================================
//  キャプチャした画像をプレビュー表示するメソッド
//  Imaage1のサイズを設定して描画する場合は，Image1.AutoSizeの値をFalseにする
//=============================================================================
procedure TForm2.PreviewCaptureImage(ABitmap: TBitmap);
begin
  //追加描画可能なように代入とする.Assignだと追加描画は不可
  FormCaptureImage.Image1.Picture.Graphic := nil;
  FormCaptureImage.Image1.Picture.Bitmap  := ABitmap;
  //キャプチャーしたビットマップを表示
  FormCaptureImage.Show;
end;

end.

unit Unit1;

interface

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

type
  TMainForm = class(TForm)
    Button1: TButton;
    Button2: TButton;
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
  private
    { Private 宣言 }
    procedure PreviewCaptureImageClipborad;
  public
    { Public 宣言 }
  end;
var
  MainForm: TMainForm;

implementation

uses FormCaptureImageUnit, Clipbrd;

{$R *.dfm}

//=============================================================================
//  [PrintScreen]キー操作をエミュレート
//  画面全体をキャプチャ
//  画面全体のビットマップ画像をコピー
//
//  このプロジェクトはApplication.MainFormOnTaskbar := False;としている
//=============================================================================
procedure TMainForm.Button1Click(Sender: TObject);
var
  LKeyByte : Byte;
  LKeyFlag : Cardinal;
begin
  //このフォームを含めない
  //アプリケーションを最小化にして，タスクバーにも表示しない
  //この処理はMainFormOnTaskbarの値によっても異なる
  Application.Minimize;
  ShowWindow(Application.Handle, SW_HIDE);

  //少しタイムラグがないと失敗する
  Sleep(100);
  LKeyByte := VK_SNAPSHOT;
  LKeyFlag := KEYEVENTF_EXTENDEDKEY;
  keybd_event(LKeyByte, MapVirtualKey(LKeyByte, 0), 0, 0);
  LKeyFlag := KEYEVENTF_KEYUP or KEYEVENTF_EXTENDEDKEY;
  keybd_event(LKeyByte, MapVirtualKey(LKeyByte, 0), LKeyFlag, 0);

  //VK_SNAPSHOTが機能する前にキャプチャ表示用のフォームが生成表示されるのを防止
  Application.ProcessMessages;
  PreviewCaptureImageClipborad;

  //Minimizeした状態から復帰
  //Application.MainFormOnTaskbarの値によっては修正が必要
  Application.Restore;
  SetForegroundWindow(Handle);
end;

//=============================================================================
//  [Alt}+[PrintScreen]キー操作をエミュレート
//  アクティブなウィンドウをキャプチャ
//  クリップボードにアクティブなウィンドウのビットマップ画像をコピー
//
//  このプロジェクトはApplication.MainFormOnTaskbar := False;としている
//=============================================================================
procedure TMainForm.Button2Click(Sender: TObject);
var
  LKeyByte : Byte;
  LAltKey  : Byte;
  LKeyFlag : Cardinal;
begin
  //このフォームをキャプチャ
  //Handleの値を他のウィンドウのものにすればそれをキャプチャ
  //子ウィンドウは不可．トップレベルのウィンドウのみ有効
  SetForegroundWindow(Handle);
  //少しタイムラグがないと失敗する
  Sleep(100);

  LKeyByte := VK_SNAPSHOT;
  LAltKey  := VK_MENU;

  LKeyFlag := KEYEVENTF_EXTENDEDKEY;
  keybd_event(LAltKey,  MapVirtualKey(LAltKey, 0),  LKeyFlag, 0);
  keybd_event(LKeyByte, MapVirtualKey(LKeyByte, 0), LKeyFlag, 0);

  LKeyFlag := KEYEVENTF_EXTENDEDKEY or KEYEVENTF_KEYUP;
  keybd_event(LAltKey,  MapVirtualKey(LAltKey, 0),  LKeyFlag, 0);
  keybd_event(LKeyByte, MapVirtualKey(LKeyByte, 0), LKeyFlag, 0);

  //VK_SNAPSHOTが機能する前にキャプチャ表示用のフォームが生成表示されるのを防止
  Application.ProcessMessages;
  PreviewCaptureImageClipborad;
end;

//=============================================================================
//  キャプチャした画像をプレビュー表示するメソッド
//  Imaage1のサイズを設定して描画する場合は，Image1.AutoSizeの値をFalseにする
//=============================================================================
procedure TMainForm.PreviewCaptureImageClipborad;
begin
  //クリップボードの画像を表示
  //Windowws Vista以降ではクリップボードから取得可能になるまでのタイムラグが必要
  Sleep(100);
  FormCaptureImage.Image1.Picture.Bitmap.Assign(Clipboard);
  FormCaptureImage.Show;
end;

end.

unit Unit1;

interface

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

type
  TMainForm = class(TForm)
    Button1: TButton;
    Button2: TButton;
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
  private
    { Private 宣言 }
    InputStructKeySet : array of TInput;
    InputStructSetCnt : Integer;
    procedure PreviewCaptureImageClipborad;
    procedure Set_InputStructKeySet(VKey: WORD; flags: DWORD);
  public
    { Public 宣言 }
  end;
var
  MainForm: TMainForm;

implementation

uses FormCaptureImageUnit, Clipbrd;

{$R *.dfm}

//=============================================================================
//  SendInput関数の第2引数であるINPUT構造体の値を設定するメソッド
//  このサンプルではキー操作なので，ItypeをINPUT_KEYBOARDとしている
//  INPUT_KEYBOARDの時は，この構造体のkiの各メンバーの値を設定する
//  マウスの場合は(ItypeがINPUT_MOUSE)，miのメンバーの各値を設定する
//
//  InputStructSetCntとInputStructKeySetはグローバル変数
//=============================================================================
procedure TMainForm.Set_InputStructKeySet(VKey: WORD; flags: DWORD);
var
  KeySt : TInput;
begin
  //INPUT構造体の配列の要素数を加算
  inc(InputStructSetCnt);
  //配列の長さを再設定
  SetLength(InputStructKeySet, InputStructSetCnt);

  KeySt.Itype          := INPUT_KEYBOARD;
  KeySt.ki.wVk         := VKey;
  KeySt.ki.wScan       := MapVirtualKey(VKey, 0);
  KeySt.ki.dwFlags     := flags or KEYEVENTF_EXTENDEDKEY;
  KeySt.ki.dwExtraInfo := 0;
  KeySt.ki.time        := 0;

  InputStructKeySet[InputStructSetCnt - 1] := KeySt;
end;

//=============================================================================
//  [PrintScreen]キー操作をエミュレート
//  画面全体をキャプチャ
//  画面全体のビットマップ画像をコピー
//
//  このプロジェクトはApplication.MainFormOnTaskbar := False;としている
//=============================================================================
procedure TMainForm.Button1Click(Sender: TObject);
begin
  //このフォームを含めない
  //アプリケーションを最小化にして，タスクバーにも表示しない
  //この処理はMainFormOnTaskbarの値によっても異なる
  //本サンプルではApplication.MainFormOnTaskbar := False;にしている
  Application.Minimize;
  ShowWindow(Application.Handle, SW_HIDE);

  //少しタイムラグがないと失敗する
  Sleep(100);

  //SendInput関数でキー操作をエミュレートする場合は
  //必ずキーを離すコード(KEYEVENTF_KEYUP)が必要
  //これをしないと，システム全体のキーバインド(操作)が狂ってしまうので注意
  //InputStructSetCntとInputStructKeySetはグローバル変数
  InputStructSetCnt := 0;
  Set_InputStructKeySet (VK_SNAPSHOT, 0);
  Set_InputStructKeySet (VK_SNAPSHOT, KEYEVENTF_KEYUP);

  SendInput(InputStructSetCnt, InputStructKeySet[0], SizeOf(TInput));

  //VK_SNAPSHOTが機能する前にキャプチャ表示用のフォームが生成表示されるのを防止
  Application.ProcessMessages;
  PreviewCaptureImageClipborad;

  //Minimizeした状態から復帰
  //Application.MainFormOnTaskbarの値によっては修正が必要
  Application.Restore;
  Application.BringToFront;
end;

//=============================================================================
//  [Alt}+[PrintScreen]キー操作をエミュレート
//  アクティブなウィンドウをキャプチャ
//  クリップボードにアクティブなウィンドウのビットマップ画像をコピー
//
//  このプロジェクトはApplication.MainFormOnTaskbar := False;としている
//=============================================================================
procedure TMainForm.Button2Click(Sender: TObject);
begin
  //このフォームをキャプチャ
  //Handleの値を他のウィンドウのものにすればそれをキャプチャ
  //子ウィンドウは不可．トップレベルのウィンドウのみ有効
  SetForegroundWindow(Handle);
  //少しタイムラグがないと失敗する
  Sleep(100);

  //SendInput関数でキー操作をエミュレートする場合は
  //必ずキーを離すコード(KEYEVENTF_KEYUP)が必要
  //これをしないと，システム全体のキーバインド(操作)が狂ってしまうので注意
  //InputStructSetCntとInputStructKeySetはグローバル変数
  InputStructSetCnt := 0;

  Set_InputStructKeySet (VK_MENU,     0);
  Set_InputStructKeySet (VK_SNAPSHOT, 0);
  Set_InputStructKeySet (VK_SNAPSHOT, KEYEVENTF_KEYUP);
  Set_InputStructKeySet (VK_MENU,     KEYEVENTF_KEYUP);

  SendInput(InputStructSetCnt, InputStructKeySet[0], SizeOf(TInput));

  //VK_SNAPSHOTが機能する前にキャプチャ表示用のフォームが生成表示されるのを防止
  Application.ProcessMessages;
  PreviewCaptureImageClipborad;
end;

//=============================================================================
//  キャプチャした画像をプレビュー表示するメソッド
//  Imaage1のサイズを設定して描画する場合は，Image1.AutoSizeの値をFalseにする
//=============================================================================
procedure TMainForm.PreviewCaptureImageClipborad;
begin
  //クリップボードの画像を表示
  //Windowws Vista以降ではクリップボードから取得可能になるまでのタイムラグが必要
  Sleep(100);
  FormCaptureImage.Image1.Picture.Bitmap.Assign(Clipboard);
  FormCaptureImage.Show;
end;

end.

unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
  private
    { Private 宣言 }
    RegistHotKeyID : Integer;
    procedure PreviewCaptureImageClipborad;
    procedure WMHotKey(var Message: TWMHotKey); message WM_HOTKEY;
  public
    { Public 宣言 }
  end;
var
  Form1: TForm1;

implementation

uses FormCaptureImageUnit, Clipbrd;

{$R *.dfm}

//=============================================================================
//  フォーム生成時の処理
//  [Ctrl]+[A]をホットキーとして登録
//=============================================================================
procedure TForm1.FormCreate(Sender: TObject);
var
  SetKey   : Cardinal;
  SetShift : Cardinal;
begin
  SetKey  := Ord('A');
  SetShift:= MOD_CONTROL;

  //文字列を識別する一意の値をホットキーIDとする
  RegistHotKeyID := GlobalAddAtom('MyCaptureTest');
  //ホットキーを登録する
  RegisterHotkey(Handle, RegistHotKeyID, SetShift, SetKey);
end;

//=============================================================================
//  フォーム破棄時の処理
//=============================================================================
procedure TForm1.FormDestroy(Sender: TObject);
begin
  if RegistHotKeyID <> 0 then begin
    //アトムに関連付けられている文字列を、アトムテーブルから削除
    GlobalDeleteAtom(RegistHotKeyID);
    //ホットキーの登録解除
    UnregisterHotKey(Handle, RegistHotKeyID);
  end;
end;

//=============================================================================
//  ホットキーが押された時の処理
//  ホットキーが押された時にアクティブなウィンドウをキャプチャ
//=============================================================================
procedure TForm1.WMHotKey(var Message: TWMHotKey);
var
  LKeyByte : Byte;
  LAltKey  : Byte;
  LKeyFlag : Cardinal;
begin
  if Message.HotKey = RegistHotKeyID then begin
    //以下にホットキーが押された時の処理を書く
    //ここでは[Print Screen]で現在アクティブなウィンドウをキャプチャ
    LKeyByte := VK_SNAPSHOT;
    LAltKey  := VK_MENU;

    LKeyFlag := KEYEVENTF_EXTENDEDKEY;
    keybd_event(LAltKey,  MapVirtualKey(LAltKey, 0),  LKeyFlag, 0);
    keybd_event(LKeyByte, MapVirtualKey(LKeyByte, 0), LKeyFlag, 0);

    LKeyFlag := KEYEVENTF_EXTENDEDKEY or KEYEVENTF_KEYUP;
    keybd_event(LAltKey,  MapVirtualKey(LAltKey, 0),  LKeyFlag, 0);
    keybd_event(LKeyByte, MapVirtualKey(LKeyByte, 0), LKeyFlag, 0);

    //VK_SNAPSHOTが機能する前にキャプチャ表示用のフォームが生成表示されるのを防止
    Application.ProcessMessages;
    PreviewCaptureImageClipborad;
  end;
end;

//=============================================================================
//  キャプチャした画像をプレビュー表示するメソッド
//  Imaage1のサイズを設定して描画する場合は，Image1.AutoSizeの値をFalseにする
//=============================================================================
procedure TForm1.PreviewCaptureImageClipborad;
begin
  //クリップボードの画像を表示
  //Windowws Vista以降ではクリップボードから取得可能になるまでのタイムラグが必要
  Sleep(100);
  FormCaptureImage.Image1.Picture.Bitmap.Assign(Clipboard);
  FormCaptureImage.Show;
end;

end.

unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    Button1: TButton;
    procedure Button1Click(Sender: TObject);
  private
    { Private 宣言 }
    function GetWindowRectForVista(hWindow: HWND): TRect;
    procedure PreviewCaptureImage(Bmp: TBitmap);
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

uses FormCaptureImageUnit, MMSystem;

{$R *.dfm}

//=============================================================================
//  Windows Vista以降では，フォームのフレームの仕様が拡張されている
//  これを考慮したウィンドウのTRect構造体の値を取得
//=============================================================================
function TForm1.GetWindowRectForVista(hWindow: HWND): TRect;
var
  ARect : TRect;
begin
  //Windows Vista以降は拡張フレーム
  if CheckWin32Version(6, 0) then begin
    //拡張したウィンドウのフレームのTRect構造体の値を取得
    DwmGetWindowAttribute(hWindow,
                          DWMWA_EXTENDED_FRAME_BOUNDS,
                          @ARect,
                          SizeOf(TRect));
  end else begin
    GetWindowRect(hWindow, ARect);
  end;
  Result := ARect;
end;

//=============================================================================
//  キャプチャ対象のウィンドウのデバイスコンテキストと互換のビットマップを作成
//  して，そこに対象ウィンドウの範囲をCopyRectする例
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);

//CAPTUREBLTは少なくともDelphi XE以前にはないので定義
const
  CAPTUREBLT = $40000000;
var
  StartTime    : DWORD;
  ScreenDC     : HDC;
  hTargetWnd   : HWND;
  TargetRect   : TRect;
  bmpOrigin    : TBitmap;

  hWindowHDC   : HDC;
  ScreenCanvas : TCanvas;
begin
  //指定時間が経過したらキャプチャ開始
  Starttime := timeGetTime;
  while (timeGetTime - StartTime) < 3000 do begin
    Sleep(100);
    Application.ProcessMessages;
  end;

  //その時アクティブなウィンドウをキャプチャー
  hTargetWnd := Windows.GetForegroundWindow;
  //そのウィンドウのデバイスコンテキストを取得
  hWindowHDC := GetWindowDC(hTargetWnd);

  //デスクトップのデバイスコンテキスを取得
  ScreenDC := CreateDC('DISPLAY', nil, nil, nil);
  //スクリーンのキャンバス生成
  ScreenCanvas := TCanvas.Create;
  //そのハンドルを設定(この値がないと描画不可)
  ScreenCanvas.Handle := ScreenDC;

  //キャプチャ対象ウィンドウのサイズと位置を取得
  //Vista以降の拡張フレーム対応
  TargetRect := GetWindowRectForVista(hTargetWnd);

  //確認のために少し大きいサイズでキャプチャ
  TargetRect.Left   := TargetRect.Left   - 11;
  TargetRect.Top    := TargetRect.Top    - 11;
  TargetRect.Right  := TargetRect.Right  + 16;
  TargetRect.Bottom := TargetRect.Bottom + 18;

  //キャプチャーした画像を格納するビットマップを作成
  bmpOrigin := TBitmap.Create;
  //そのビットマップを，対象ウィンドウ関連のあるデバイスと互換性とする
  bmpOrigin.Handle := CreateCompatibleBitmap(
                             hWindowHDC,
                             TargetRect.Right  - TargetRect.Left,
                             TargetRect.Bottom - TargetRect.Top);

  try
    bmpOrigin.Canvas.CopyRect(
        Rect(0,
             0,
             TargetRect.Right  - TargetRect.Left,
             TargetRect.Bottom - TargetRect.Top),
　      ScreenCanvas,
        Rect(TargetRect.Left,
             TargetRect.Top,
             TargetRect.Right,
             TargetRect.Bottom));

    //キャプチャした画像をプレビュー表示
    PreviewCaptureImage(bmpOrigin);
  finally
    //解放処理
    FreeAndNil(bmpOrigin);
    ReleaseDC(hTargetWnd, hWindowHDC);
    ScreenCanvas.Free;
    DeleteDC(ScreenDC);
  end;
end;

//=============================================================================
//  キャプチャしたビットマップをプレビュー表示するメソッド
//  Imaage1のサイズを設定して描画する場合は，Image1.AutoSizeの値をFalseにする
//=============================================================================
procedure TForm1.PreviewCaptureImage(Bmp: TBitmap);
begin
  //追加描画可能なように代入とする.Assignだと追加描画は不可
  FormCaptureImage.Image1.Picture.Bitmap := nil;
  FormCaptureImage.Image1.Picture.Bitmap := Bmp;
  FormCaptureImage.Image1.Update;

  FormCaptureImage.Show;
end;

end.

unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    Button1: TButton;
    procedure Button1Click(Sender: TObject);
  private
    { Private 宣言 }
    function GetWindowRectForVista(hWindow: HWND): TRect;
    procedure PreviewCaptureImage(Bmp: TBitmap);
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

uses FormCaptureImageUnit, MMSystem;

{$R *.dfm}

//=============================================================================
//  Windows Vista以降では，フォームのフレームの仕様が拡張されている
//  これを考慮したウィンドウのTRect構造体の値を取得
//=============================================================================
function TForm1.GetWindowRectForVista(hWindow: HWND): TRect;
var
  ARect : TRect;
begin
  //Windows Vista以降は拡張フレーム
  if CheckWin32Version(6, 0) then begin
    //拡張したウィンドウのフレームのTRect構造体の値を取得
    DwmGetWindowAttribute(hWindow,
                          DWMWA_EXTENDED_FRAME_BOUNDS,
                          @ARect,
                          SizeOf(TRect));
  end else begin
    GetWindowRect(hWindow, ARect);
  end;
  Result := ARect;
end;

//=============================================================================
//  スクリーンのデバイスコンテキストではなく，対象のウィンドウのデバイスコンテ
//  キストを使用する例
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);

//CAPTUREBLTは少なくともDelphi XE以前にはないので定義
const
  CAPTUREBLT = $40000000;
var
  StartTime    : DWORD;
  hTargetWnd   : HWND;
  TargetRect   : TRect;
  bmpOrigin    : TBitmap;
  hWindowHDC   : HDC;
begin
  //指定時間が経過したらキャプチャ開始
  Starttime := timeGetTime;
  while (timeGetTime - StartTime) < 3000 do begin
    Sleep(100);
    Application.ProcessMessages;
  end;

  //その時アクティブなウィンドウをキャプチャー
  hTargetWnd := Windows.GetForegroundWindow;
  //そのウィンドウのデバイスコンテキストを取得
  hWindowHDC := GetWindowDC(hTargetWnd);

  //キャプチャ対象ウィンドウのサイズと位置を取得
  //Vista以降の拡張フレーム対応
  TargetRect := GetWindowRectForVista(hTargetWnd);

  //キャプチャーした画像を格納するビットマップを作成
  bmpOrigin             := TBitmap.Create;
  bmpOrigin.PixelFormat := pf32bit;
  bmpOrigin.Width       := TargetRect.Right  - TargetRect.Left;
  bmpOrigin.Height      := TargetRect.Bottom - TargetRect.Top;

  try
    BitBlt(bmpOrigin.Canvas.Handle,
           0,
           0,
           TargetRect.Right  - TargetRect.Left,
           TargetRect.Bottom - TargetRect.Top,
           hWindowHDC,
           0,
           0,
           SRCCOPY or CAPTUREBLT);

    //キャプチャした画像をプレビュー表示
    PreviewCaptureImage(bmpOrigin);
  finally
    //解放処理
    FreeAndNil(bmpOrigin);
    ReleaseDC(hTargetWnd, hWindowHDC);
  end;
end;

//=============================================================================
//  キャプチャしたビットマップをプレビュー表示するメソッド
//  Imaage1のサイズを設定して描画する場合は，Image1.AutoSizeの値をFalseにする
//=============================================================================
procedure TForm1.PreviewCaptureImage(Bmp: TBitmap);
begin
  //追加描画可能なように代入とする.Assignだと追加描画は不可
  FormCaptureImage.Image1.Picture.Bitmap := nil;
  FormCaptureImage.Image1.Picture.Bitmap := Bmp;
  FormCaptureImage.Image1.Update;

  FormCaptureImage.Show;
end;

end.

unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    Button1: TButton;
    procedure Button1Click(Sender: TObject);
  private
    { Private 宣言 }
    function GetWindowRectForVista(hWindow: HWND): TRect;
    procedure PreviewCaptureImage(Bmp: TBitmap);
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

uses Winspool, FormCaptureImageUnit, MMSystem;

{$R *.dfm}

//=============================================================================
//  Windows Vista以降では，フォームのフレームの仕様が拡張されている
//  これを考慮したウィンドウのTRect構造体の値を取得
//=============================================================================
function TForm1.GetWindowRectForVista(hWindow: HWND): TRect;
var
  ARect : TRect;
begin
  //Windows Vista以降は拡張フレーム
  if CheckWin32Version(6, 0) then begin
    //拡張したウィンドウのフレームのTRect構造体の値を取得
    DwmGetWindowAttribute(hWindow,
                          DWMWA_EXTENDED_FRAME_BOUNDS,
                          @ARect,
                          SizeOf(TRect));
  end else begin
    GetWindowRect(hWindow, ARect);
  end;
  Result := ARect;
end;

//=============================================================================
//  PrintWindow関数によるキャプチャ
//  PrintWindowの使用には，usesにWinspoolが必要
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);

//CAPTUREBLTは少なくともDelphi XE以前にはないので定義
const
  CAPTUREBLT = $40000000;
var
  StartTime    : DWORD;
  hTargetWnd   : HWND;
  TargetRect   : TRect;
  bmpOrigin    : TBitmap;
begin
  //指定時間が経過したらキャプチャ開始
  Starttime := timeGetTime;
  while (timeGetTime - StartTime) < 3000 do begin
    Sleep(100);
    Application.ProcessMessages;
  end;

  //その時アクティブなウィンドウをキャプチャー
  hTargetWnd := Windows.GetForegroundWindow;

  //キャプチャ対象ウィンドウのサイズと位置を取得
  //Vista以降の拡張フレーム対応
  TargetRect := GetWindowRectForVista(hTargetWnd);

  //キャプチャーした画像を格納するビットマップを作成
  bmpOrigin             := TBitmap.Create;
  bmpOrigin.PixelFormat := pf32bit;
  bmpOrigin.Width       := TargetRect.Right  - TargetRect.Left;
  bmpOrigin.Height      := TargetRect.Bottom - TargetRect.Top;

  try
    bmpOrigin.Canvas.Lock;
    //最後の引数を1(=PW_CLIENTONLY)にするとクライアント領域となる
    PrintWindow(hTargetWnd, bmpOrigin.Canvas.Handle, 0);
    bmpOrigin.Canvas.Unlock;

    //キャプチャした画像をプレビュー表示
    PreviewCaptureImage(bmpOrigin);
  finally
    //解放処理
    FreeAndNil(bmpOrigin);
  end;
end;

//=============================================================================
//  キャプチャしたビットマップをプレビュー表示するメソッド
//  Imaage1のサイズを設定して描画する場合は，Image1.AutoSizeの値をFalseにする
//=============================================================================
procedure TForm1.PreviewCaptureImage(Bmp: TBitmap);
begin
  //追加描画可能なように代入とする.Assignだと追加描画は不可
  FormCaptureImage.Image1.Picture.Bitmap := nil;
  FormCaptureImage.Image1.Picture.Bitmap := Bmp;
  FormCaptureImage.Image1.Update;

  FormCaptureImage.Show;
end;

end.

unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    Button1: TButton;
    procedure Button1Click(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
  private
    { Private 宣言 }
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

//=============================================================================
//  デスクトップのCanvasに直接描画する方法
//
//  CreateDCの第2引数にディスプレイデバイス名を指定していないので，
//  マルチモニタ構成の場合，ScreenDCの値は仮想画面のデバイスコンテキスとなる
//  つまり，このコードはマルチモニタの場合でもそのまま使用できる
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
var
  LScreenDC     : HDC;
  LScreenCanvas : TCanvas;
begin
  //デスクトップのデバイスコンテキスを取得
  //第2引数でモニタのデバイスコンテキスト
  LScreenDC := CreateDC('DISPLAY', nil, nil, nil);
  //デスクトップのキャンバス生成
  LScreenCanvas := TCanvas.Create;
  //そのハンドルを設定(この値がないと描画不可)
  LScreenCanvas.Handle := LScreenDC;

  try
    //ベンの設定
    LScreenCanvas.Pen.Color := clRed;
    LScreenCanvas.Pen.Width := 10;
    //ブラシの設定
    LScreenCanvas.Brush.Style := bsClear;

    //設定したペンとブラシで，デスクトップに矩形を描画
    LScreenCanvas.Rectangle(100, 100, 500, 400);
  finally
    //解放処理
    LScreenCanvas.Free;
    DeleteDC(LScreenDC);
  end;
end;

//=============================================================================
//  フォームを破棄する時はデスクトップを再描画して，描画内容を消去
//=============================================================================
procedure TForm1.FormDestroy(Sender: TObject);
begin
  InvalidateRect(0, nil, True);
end;

end.