Delphi Programming / Object Pascal
サイトのトップページへ リンクのページへ ロゴマーク
[掲載 2011年12月27日] [更新 2017年08月21日] Delphi サンプルプログラム集
   
368_スクリーンキャプチャのテスト ( Windows Vista, 7 対応 )
動作確認等 Windows 7 U64(SP1) + Delphi XE Pro
Delphi 2009 よりも前のバージョンではコンパイル不可のサンプルあり
368_ScreenCaptureTest.zip [15,528 KB] 2017年08月21日版(EXE同梱)



  • 2013年09月26日
  • キャプチャした画像表示用のフォームを,全て,新規フォーム作成時と同じ [自動生成] とした.それに伴いサンプルコードを整備して記事も修正
  • サンプルをいくつか追加.ただし,内容はほとんど同じだが,タイトルと説明を変えている
  • 2013年09月29日
  • 前回の更新で,キャプチャした画像表示用フォームの OnShow が,2 回目以降発生しなくったための修正.Activate イベント処理のコードを追加して,OnShow イベントの処理コードは削除
  • 2013年10月04日
  • 矩形領域選択 (矩形範囲選択) のサンプルを追加
  • 一部のサンプルで,ビットマップの解放処理を忘れていたので修正
  • 2016年04月10日
  • 矩形領域のキャプチャのテストプログラムを,マルチモニタ対応にした




Windows Vista 以降対応のスクリーンキャプチャのテスト


Windows Vista 以降,ウィンドウのスタイルがかなり変化しました.Windows XP までの時代に作成されたスクリーンキャプチャのソフトでは,キャプチャした画像の体裁がよくない場合があります.そこで,Vista 以降でのスクリーンキャプチャのテストをしてみました.
実際のキャプチャでは,マルチモニター環境での使用も考慮する必要があるかも知れません.

キャプチャのテストの結果,取得した画像を確認できないと不便です.以下のテストでは,下図のようなキャプチャ画像を確認表示するためのフォームを使用しています.このフォームは,ルートフォルダ直下にあります.このキャプチャ画像確認用フォームをプロジェクトに追加しています.

プロジェクトソースの MainFormOnTaskbar の値を Falseにしているサンプルがあります.これはアプリケーションウィンドウに対する対応策です.この値がデフォルトの True のままだと正常にキャプチャできないことがあります.

また,一定時間経過後にキャプチャするために,待ち時間の設定に Sleep 関数を使用しているサンプルがありますが,本来は,この目的で Sleep 関数を使用するのは望ましくありません.簡便なのでテスト目的で使用していますが,Sleep 関数を使用すると,正常に動作しないサンプルがあります.

サンプルプログラムの多くは,システムのアニメーション効果を有効にしていると,正常にキャプチャできない場合があります.


[備考]
アルファチャンネル付きのキャプチャと,背景色を指定するキャプチャは,アクティブなウィンドウのキャプチャ用ですが,これらのキャプチャでは,原理的に半透明のウィンドウは正常にキャプチャできません.



図1
キャプチャ画像確認用フォーム
  • フォーム上の Image1 の AutoSize プロパティの値を Ttue にしている (デフォルトは False)

本ページのサンプルでは,キャプチャしたビットマップを TImage.Picture.Bitmap に直接代入しています.このコードのままだと,アルファチャンネルの情報が失われます.そのため,保存した画像に「ゴミ」が入ることがあります.

この現象を回避するには,キャプチャしたビットマップを直接保存するか,あるいは以下のように,あらかじめ TImage.Picture.Bitmap をアルファチャンネルの処理可能に設定します.または,キャプチャしたビットマップを Assign で代入してください.



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;


以下はサンプルプログラムのプロジェクトソースです.
Application.MainFormOnTaskbar := False としているサンプルあります.このキャプチャ画面表示確認用フォームをプロジェクトに追加して施用しています.


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.




01_Vista 以降の拡張フレームのウィンドウ


Windows XP までは,GetWindowRect 関数でウィンドウのサイズを取得していましたが,Vista 以降では,DwmGetWindowAttribute 関数を使用します.第 2 引数に DWMWA_EXTENDED_FRAME_BOUNDS を指定すると,拡張フレームに対応したウィンドウのサイズを取得できます.
その確認用のテストプログラムです.


  図2
GetWindowRect 関数でのキャプチャ結果
図3
DwmGetWindowAttribute 関数でのキャプチャ結果

リスト1
Vista 以降の拡張フレームに対応したウィンドウのサイズ取得のテスト
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.




02_デスクトップやワークエリアのサイズ


画面のデスクトップやワークエリアのサイズの取得方法は,Windows Vista 以降でも,Windows XP 以前の方法と同じです.
デスクトップは,マルチモニタ環境の場合,本来は,全てのモニタを含めた全体を意味するのだそうですが,次のコードは,プライマリのディスプレイモニタ (主ディスプレイ) の画面のキャプチャをするサンプルです.上のサンプルのコードで,キャプチャの範囲をデスクトップやワークエリアのサイズに変更しているだけです.

TScreen 変数には,この他,デスクトップのサイズやワークエリアのサイズを取得するための,プロパティがいくつかあります.



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.




03_ウィンドウの下に表示される影の部分のサイズ


Vista 以降で実装された,ウィンドウの下の影の部分もキャプチャするには,この影の部分の大きさを知る必要があります.
このテストプログラムでは,このサイズを調べるために,そのままキャプチャしたビットマップと,背景を塗り潰したフォームの上に対象のウィンドウを表示してキャプチャしたビットマップを作成しています.このビットマップの大きさを少し大き目にしておきます.
この 2 つから下図のような画像を作成します.この図で,多分リージョンと思われますが,非矩形の領域が「影」の部分となります.
Windows には,この影の部分についての情報を取得するための API は用意されていないようです.

下図は,パフォーマンスオプションの [ウィンドウの下に影を表示する] のチェックが入っている状態で実行した結果です.


図4
ウィンドウの「影」の部分

リスト2
ウィンドウの「影」の部分を調べるサンプル
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.




04_ウィンドウの下の影部分も含めてキャプチャ


前のテストプログラムで「影」の部分のサイズを知ることができました.この情報を元に,ウィンドウのフレームサイズに,これらの値を加算したサイズでキャプチャする例です.

下図は,パフォーマンスオプションの [ウィンドウの下に影を表示する] のチェックが入っている状態で実行した結果です.


図5
ウィンドウの影の部分も含めてキャプチャ

リスト3
ウィンドウの影の部分も含めてキャプチャ
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.




05_背景色を指定したキャプチャー


ウィンドウの影の部分のサイズを調べるテストで,表面を単一色で塗り潰したフォームを使用しました.これを利用して,背景色を指定してキャプチャする例です.
背景色用のフォームの上に対象のウィンドウを表示してキャプチャします.

この方法は,対象のウィンドウが,あるアプリケーションのウィンドウの 1 つである場合,そのアプリケーションのウィンドウが背景に表示されていると,そのウィンドウが背景となってキャプチャされてしまいます.これは,アプリケーションの特定のウィンドウだけを,システム全体の中でZオーダーを変更できないためです.Z オーダーの変更はアプリケーション全体のウィンドウに働きます.

Windows XP では,単色で塗りつぶしたビットマップに,ウィンドウのリージョンを取得して重ね描画することができましたが,Windows Vista 以降では,この方法は使用できないようです.

下図は,パフォーマンスオプションの [ウィンドウの下に影を表示する] のチェックが入っている状態で実行した結果です.


[備考]
背景色を指定する方法には,対象のウィンドウを非表示にした背景画像と,対象のウィンドウが含まれる同じ領域の画像から,背景画像を差し引いて取得する方法も考えられます.この場合,ウィンドウの影 (Drop Shadow) の処理が課題となるかも知れません.この影は半透明ですから,背景の色も反映された色となります.



図6
背景色を白にしたキャプチャ
図7
背景色を別の色にしてキャプチャ

リスト4
背景色を指定したキャプチャ.背景色を設定するためのフォームを別に使用
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.




06_アルファチャンネル付きキャプチャ - 背景色指定兼用


Delphi 2009 から,TBitmap でアルファチャンネルの操作が可能となりました.
ウィンドウの影の部分は元々半透明です.そこで,アルファチャンネル処理をしたキャプチャをしてみました.下図がその結果です.
この図では,キャプチャ画像を表示するフォームの背景が透過して見えています.フォームの色を背景色にしてキャプチャしたわけではありません.

このサンプルコードでは,背景を黒と,白にした状態でキャプチャした 2 つのビットマップを元にアルファチャンネルの処理を行っています.
下図は,パフォーマンスオプションの [ウィンドウの下に影を表示する] のチェックが入っている状態で実行した結果です.



図8
アルファチャンネル付き

作成した関数 CaptureWindowImage は背景色を指定したキャプチャも可能にしています.また, [ウィンドウの下に影を表示する] になっていても,影なしのキャプチャができるようにしています.



図9
影なしキャプチャ
図10
背景色を指定したキャプチャ

リスト5
ウィンドウの影の部分をアルファチャンネル付きでキャプチャする例
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.




07_透過状態の確認用の画像を背景に描画


アルファチャンネル付きでキャプチャした場合,透過状態を確認するために,市松模様の画像を背景に描画する方法がよく利用されています.
本ページのサンプルで使用している添付のプレビュー画面の場合,TScrollBox の Brush プロパティにビットマップ画像を指定すれば背景としての画像を表示できます.下図はその例です.



図11
背景に透過状態確認用の画像を表示

リスト6
キャプチャ画像表示用のプレビュー画面の背景に,透過状態確認用の画像を表示する例
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.




08_アルファチャンネル付き画像を TImage に描画


上のサンプルコードで保存したビットマップは,アルファチャンネル付きのビットマップを表示できるアプリケーションでなければ正しく表示できません.Photoshop (どのバージョンからかは不明) ではサポートしているようです.また,現在は多くのウェブブラウザがアルファチャンネル付き画像の表示が可能となっていますが,ビットマップのアルファチャンネルはサポートしていません..

TImage で表示する場合は,次のコードのように,TBitmap の AlphaFormat の値を afDefined にします.AlphaFormat のデフォルトである afIgnored のままだとアルファチャンネル部分の情報は描画されません.このプロパティは,Delphi 2009 以降に実装されています.

下図は,この上のサンプルでキャプチャして保存した,添付の画像を表示したものです.



図12
設計時画面
図13
AlphaFormat=afDefined で表示
  • 半透明部分が表示されている
図14
AlphaFormat=afIgnored の場合
  • アルファチャンネルの情報があるピクセルの部分,つまり,半透明部分は黒となる

リスト7
アルファチャンネル付きのビットマップを表示する
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.




09_ウィンドウの下の影 ( Drop Shadow ) の表示・非表示の切り換え


ウィンドウの下に影を表示するかしないかは,[パフォーマンスオプション] のダイアログで設定できます.[パフォーマンスオプション] のダイアログは以下のコマンドで起動できます.
プログラムで設定する場合は SystemParametersInfo 関数の SPI_SETDROPSHADOW が利用できます.


SystemPropertiesPerformance.exe


図15
パフォーマンスオプションのダイアログ
  • ダイアログ表示の際,管理者への昇格確認のダイアログが表示される
  • [ウィンドウの下に影を表示する] で設定する

以下は実際に SystemParametersInfo 関数で設定する例です.
パフォーマンスオプションのダイアログの表示には管理者権限が必要ですが, SystemParametersInfo 関数で設定する場合は管理者権限は必要ありません.



図16
影を表示してキャプチャ
  • 影を表示しない設定になっていても影付きでキャプチャできる
  • モニタの白い領域にウィンドウを表示してキャプチャしている
図17
影を表示しないでキャプチャ
  • 影を表示する設定になっていても影なしでキャプチャできる

リスト8
ウィンドウの下の影を表示または非表示にしてキャプチャ
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.




10_マウスカーソル下のウィンドウの検出


マウスカーソル位置のウィンドウをキャプチャするには,マウスカーソルがあるウィンドウのハンドルが必要です.これには,WindowFromPoint 関数が使用できますが,この関数は無効化されているウィンドウ (Enabled プロパティが False) は検出してくれません.取得結果は,その親のウィンドウハンドルとなってしまいます (親が無効化の時はそのまた親).
MSDN オンラインの記事には、ChildWindowFromPoint 関数を使用するようなことが書いてありますが,このサンプルでは,EnumChildWindows関数 を再帰的に実行して検索しています.
下のリンクの [Delphi 6 ローテク Tips/マウスカーソル下のウィンドウを取得] の記事のように,再起処理をしないで,ChildWindowFromPoint 関数でも取得可能なコードは書けますが,少しばかり面倒になります.

このサンプルコードでは,3 秒後にウィンドウの情報を取得していますが,これをグローバルホットキー等で取得開始にすれば,マウスカーソル下のウィンドウの情報取得のツールが作成できます.



[備考]
ウィンドウの各種情報の取得には,Halbow 資料館の WinSearch ユニットが使用できますが,Delphi 2009 以降でコンパイルすると,実行時に例外が発生します.
Delphi 2009 以降で使用可能なコードを,[645_ウィンドウの階層のツリー表示] のサンプルに添付しています.

「ウィンドウ」は,フォーム等,視覚的なウィンドウを意味することもありますが,ここでいう「ウィンドウの検出」のウィンドウは,ウィンドウハンドルを持つコントロールを意味します.

ウィンドウハンドルを持たないコントロールやオブジェクトの情報は,IAccessible インターフェイス や UI Automation インターフェイスを使用すると取得できますが,これらの機能を使用しても,全てのオブジェクトが取得できるわけではありません.
Delphi VCL フォームアプリケーションの TLabel, TImage 等の TGraphicControl は Windows が提供しているコントロールをラッピングしたものではありません.Delphi 特有のコントロールです.このようなコントロールは検出できません.例えば,TLabel は,ウィンドウハンドルを持つコントロールに描画した「絵」のようなものと考えてください.

自アプリ内であれば,[マウスコントロール下のコントロールの取得] の記事にあるように,VCL のコントロール,コンポーネント類の検出が可能です.



図18
マウスカーソル下のウィンドウ
  • Button1 をクリックすると,3秒後にマウスカーソルがあるウィンドウを検出
  • この図は Button5 にある場合
  • 他のアプリのウィンドウも検出可能

リスト9
マウスカーソル下のウィンドウを検出するサンプルコード
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.




11_マウスカーソルのキャプチャ


スクリーンキャプチャでは,マウスカーソルは別にキャプチャし,キャプチャしたビットマップ画像に重ね描画することになります.このマウスカーソルのキャプチャのコードは Halbow 資料館の[スクリーンのキャプチャ] のページににありますが,ここに再掲しておきます.

マウスカーソルの位置座標と,実際のクリック座標とは異なります.矢印の形をしたマウスカーソルの場合は,矢印の先端がクリック座標です.この座標の差をホットスポット言っています.
このサンプルは,マウスカーソルの画像をビットマップとして取得して描画するだけです.スクリーンキャプチャした画像に重ねて表示する場合は,ホットスポット分を調整しないと,マウスカーソルの画像がずれてしまいます.
ホットスポットの値は,TCursorInfo.xHotspot, TCursorInfo.yHotspot で取得できます.



図19
実行結果例

リスト10
マウスカーソルのキャプチャ
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.




12_マウスカーソルの影の部分のキャプチャ


Windows 2000 以降,デフォルトでは,マウスカーソルの下に「影 (ドロップシャドウ)」がありますが,これはキャプチャしません.この影の部分は,MSDN のレイヤーウィンドウの説明の記事にあるように,アルファシャドー (半透明の影) のレイヤーウィンドウですが,マウスカーソルもこの影の部分もウィンドウとしては検出できません.
影の部分のキャプチャが必要であれば,自前で描画することになります.MSDN オンラインの記事によれば,不透明度は 75 % の黒,2 ピクセルの幅のようです.
独自のマウスカーソルを作成する場合も同じです.マウスカーソルの実態はアイコンです.

次のコードは,この影を含めたマウスカーソルの画像を取得するためのコード例です.MSDN オンラインの記事では不透明度が 75 % となっていますが,ここでは,目視で 50 % と決定しました.



図20
影付きでマウスカーソルをキャプチャ
図21
影の部分はアルファシャドウ

リスト11
影付きでマウスカーソルをキャプチャ
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.


マウスカーソルの「影」の部分は実際には「ぼかし」になっていますが,本サンプルではぼかしはしていません.下図はキャプチャした実際の画像を拡大表示したものです.



図22
上のコードで取得したマウスカーソル画像
  • 左がその画像
    ぼかしはない
  • 右は実際のスクリーン上の画像
    影の画像がぼかし画像となっている

下図は,マウスカーソルのマスク画像を半透明にした後にガウスぼかしを実行した画像です.下に示すコードを使用しています.不透明度の値を,マイクロソフトの記事に書いてある 75% にしています.



図23
下のコードで取得したマウスカーソル画像
  • 左がその画像
  • 右は実際のスクリーン上の画像
  • ほとんど同じように見えるが,もう少し不透明度を下げてもいいかも知れない

リスト12
影付きでマウスカーソルをキャプチャ
半透明のマスク画像をガウスぼかしでぼかす例
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.




13_マウスポインタの影 ( Drop Shadow ) の表示・非表示の切り換え


マウスカーソルの下に影を表示するかしないかは,[パフォーマンスオプション] のダイアログで設定できます.[パフォーマンスオプション] のダイアログは以下のコマンドで起動できます.
プログラムで設定する場合は SystemParametersInfo 関数の SPI_SETCURSORSHADOW が利用できます.


SystemPropertiesPerformance.exe


図24
パフォーマンスオプションのダイアログ
  • ダイアログ表示の際,管理者への昇格確認のダイアログが表示される
  • [マウスポインターの下に影を表示する] で設定する

以下は実際に SystemParametersInfo 関数で設定する例です.
パフォーマンスオプションのダイアログの表示には管理者権限が必要ですが, SystemParametersInfo 関数で設定する場合は管理者権限は必要ありません.

このサンプルは,起動するとマウスカーソルに影を表示する設定になっていると,チェックボックスをチェックします.このチェックボックスで影の表示と非表示を切り換えます.
影を表示するに設定しても,影を表示しないカーソルもあります.その確認用に,システム関係のマウスカーソルの一覧を取得しています.自作のマウスカーソルも影は表示しません.

マウスカーソルの影の部分は,キャプチャと言うより,キャプチャするアプリ側が自力で描画しなければなりません.しかも影を表示する設定にしていても影を表示しないマウスカーソル (マウスポインタ) もあるわけですから,結構面倒です.



図25
影を表示する設定の場合
図26
影を表示しない設定の場合
図27
影を表示しないマウスポインタの例
  • 影を表示する設定になっていても,影を表示しないマウスカーソルもある

リスト13
マウスポインタの影の表示と非表示を切り換える
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.


上のコードで,マウスカーソルを変更する時にマウスカーソルのハンドルを取得しています.このマウスカーソルのハンドルは TScreen 変数で使用するハンドルです.現在のマウスカーソルのハンドルは上のコードで使用している GetCursorInfo 関数の他,GetCursor 関数でも取得できます.
上のコードではハンドルを TScreen 変数に代入しているだけですから, DestroyCursor(LhCursor) で破棄する必要はありません.これはアイコンのバンドルの扱いと同じです.




リスト14
GetCursor 関数でマウスカーソルのハンドルを取得して DrawIconEx で描画する例
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;


リスト15
GetCursor 関数でマウスカーソルのハンドルを取得して DrawIcon で描画する例
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;




14_マウスカーソルを含めたスクリーンキャプチャ


マウスカーソルのキャプチャができるようになったので,実際にキャプチャする時に,マウスカーソルも同時にキャプチャしてみます.ただし,マウスカーソルの影の部分の処理はありません.

下図は,パフォーマンスオプションの [ウィンドウの下に影を表示する] のチェックを外した状態で実行したものです.



図28
実行結果
  • ボタンの上のマウスカーソルもキャプチャされている

リスト16
マウスカーソルも同時にキャプチャ
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.




15_ポップアップメニュー等も含めたキャプチャ


ここまでのキャプチャは,デスクトップの画面の一部をビットマップにしています.キャプチャの再にポップアップメニューやツールチップが表示されていれば,それも含めてキャプチャします.

ただし,対象のウィンドウの外側に表示されている部分はキャプチャ画像には含まれません.この外側の部分も含めるには,メニュー類の領域を算出してキャプチャー範囲に含めます.
このサンプルでは,メニュー類のハンドルから,そのメニューウィンドウのサイズを求めています.

このサンプルでは Sleep 関数を使用していません.Sleep 関数はプロセスの実行そのものを提示してしまうため,Sleep 関数実行中にメニューを表示しても,メニュー類の表示を検出できません.
そこで,TTimer コンポーネントを使用して,プロセスの実行を中断しないようにしています.



図29
設計時画面
  • TTimer コンポーネントを使用

下図が実行結果です.背景色の設定もしてみました.
背景色を透明色にしたり,透明化すると,ウェブページに掲載したり,ワード等に表示する際,この背景色の部分を透明にできます.

下図は,パフォーマンスオプションの [ウィンドウの下に影を表示する] のチェックを外した状態で実行した結果です.

このサンプルは,ポップアップメニューやツールチップのウィンドウが Z オーダのトップで表示されることを利用しています.したがって,拡張スタイルに WS_EX_TOPMOST を指定したウィンドウが起動しているとメニューやツールチップのウィンドウが検出できなくなり,キャプチャ範囲が取得できないことがあります.



図30
ツールチップを含める
図31
ポップアップメニューを含める

リスト17
ポップアップメニューやツールチップの範囲も含めてキャプチャ.背景色も設定
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.


「ウィンドウの影の部分」を含める場合は,次のように,影の領域を追加します.
dropShadoeSize は,ポップアップメニュー類の「影」の部分のサイズです.


リスト18
ホットキーを使用してアクティブなウィンドウをキャプチャ
  //[ウィンドウの下に影を表示する]になっている場合
  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;




16_親ウィンドウも含めたキャプチャ


アプリケーションで別のフォーム,あるいはダイアログを表示したとします.この時,ダイアログをキャプチャする際,親ウィンドウも同時にキャプチャする例です.
ダイアログのプロセスID と同じプロセスID が同じウィンドウをキャプチャ範囲に含めます.

下図は,パフォーマンスオプションの [ウィンドウの下に影を表示する] のチェックを外した状態で実行した結果です.



図32
この状態をキャプチャする
図33
キャプチャした結果

リスト19
サンプルのメインフォームのコード.別のフォームを表示するだけ
//=============================================================================
//  Form2を表示
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
begin
  Form2.ShowModal;
end;


リスト20
親ウィンドウも含めたキャプチャ
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.




17_PrintScreen をコードで実行  -  自アプリを非キャプチャしない


Windows では [PrintScreen] キー (キーボードの表記は [PrtSc]) でスクリーンの画像をクリップボードにコピーできます.[Alt] + [PrtSc] がアクティブなウィンドウとなります.
これを keybd_event 関数を使用してプログラムで実行するサンプルプログラムです.実行後,クリップボードの画像をビットマップ画像として取得します.

このサンプルでは,デスクトップのキャプチャの時に,このサンプルプログラム自身を最小化し,自分自身をキャプチャしないようにしています.この時,フォームを最小化するのではなく,アプリケーションウィンドウを最小化します.
フォームを最小化すると,(デフォルトでは) ワークエリアの左下に最小化したウィンドウが表示されてしまいます.
また,タスクバーにも,アプリケーションのアイコンを表示しないようにしてみました.そうすると,キャプチャ用のプログラムが起動していない状態と同じデスクトップ画面をキャプチャすることができます.

クリップボードを使用する場合,キー操作のメッセージをシステムに送る前に,画面の状態を安定させないとキャプチャの範囲や画像が期待するものと違う結果となることがあります.そのためにタイムラグを設けています.
クリップボードを経由する方法は,Windows 2000 以前では,これらをあまり考慮する必要がなかったのですが,Windows Vista 以降では結構面倒です.

デスクトップやワークエリアのキャプチャの参考コードは,本ページの最初の方にあります.



図34
デスクトップのキャプチャ
  • このフォームはキャプチャしない
  • タスクバーにも非表示
図35
デスクトップのキャプチャ
  • アニメーション効果が有効な場合
  • タスクバーのアイコンも,完全には非表示とはなっていない
  • もう少しタイムラグが必要
図36
このフォームのキャプチャ結果

リスト21
[PrintScreen] のキー操作をプログラムで実行
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.




18_Keybd_event と SendInput


上のサンプルの [ PrintScreen ] キーによるコードの Keybd_event の使い方は特殊ですが,マイクロソフトでは,Keybd_event 関数の代りに SendInput 関数の使用を勧めています.この SendInput 関数を使用する例です.
SendInput 関数を使用する場合,キー操作のキーを押す,離す操作の両方を必ず設定します.そうしないとシステムのキー設定が狂ってしまい,思わぬ結果を招くことになります.

動作は上のサンプルと同じです.



リスト22
SendInput 関数によるキー操作のエミュレート例
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.




19_ ボタンクリックではなく,ホットキーでキャプチャ開始


他のアプリのアクティブなウィンドウをキャプチャするのに,ここまでのサンプルでは,ボタンクリック後,一定の時間経過後にアクティブであるウィンドウを対象にしてきました.
あるキーの組み合わせを,1 つだけでも構いませんが,グローバルなホットキーとして登録します.すると,そのキーあるいはキーの組み合わせを押すと,WM_HOTKEY というメッセージが発生します.
このメッセージが発生した時に何かの処理を実行することができます.
この機能を使用した,アクティブなウィンドウのキャプチャの例です.

[PrtSc] (PrintScreen) キーもホットキーとして使用できますが,アプリケーションによっては使用できない場合があります.また,[Alt] キーや [Windows] キーをホットキーにすると,これらのキーを押下した時に,ポップアップメニューが閉じます.したがって,ポップアップメニューもキャプチャしたい場合は,ホットキーとして使わないようします.

多くのスクリーンキャプチャ系のアプリケーション類は,このグローバルなホットキーを使用しているようです.グローバルなホットキーなので,システム全体で有効となります.他のアプリケーションがアクティブの時も,ホットキーの押下を自アプリ側で検出できます.

必要であれば,キャプチャ開始時にフォームを非表示にしたり,あるいは,キャプチャ用のプログラム起動時に,タスクトレイ (タスクバーの右端の [通知領域] と呼ばれる部分) に登録する,いわゆる常駐アプリケーションにすることもできます.



図37
実行時画面
  • [Ctrl] + [A] で,その時にアクティブなウィンドウをキャプチャする

リスト23
ホットキーを使用してアクティブなウィンドウをキャプチャ
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.




20_CreateCompatibleBitmap 関数


Windows API には,スクリーンやウィンドウのキャプチャに利用できる関数があります.それらをテストしてみます.
まず,CreateCompatibleBitmap 関数です.この関数は引数のデバイスコンテキストと互換のデバイスコンテキストを作成します.ここではキャプチャ対象のウィンドウのデバイスコンテキストと互換のビットマップを作成します.
キャプチャ対象のハンドルを指定すれば,コントロールや子ウィンドウでもキャプチャできます.

下図は,パフォーマンスオプションの [ウィンドウの下に影を表示する] のチェックが入った状態で実行した結果です.



図38
キャプチャ画像例

リスト24
キャプチャ対象のウィンドウのデバイスコンテキストと互換のビットマップを作成する方法
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.




21_GetWindowDC 関数


これまでのテストプログラムで使用してきた CreateDC 関数は,デスクトップのデバイスコンテキストの取得に使用しています.そして,そのデスクトップのデバイスコンテキストの,ある矩形範囲をキャプチャするものでした.

一方,特定のウィンドウのデバイスコンテキストを取得する GetWindowDC という関数があります.これを使用した例です.特定のウィンドウのデバイスコンテキストの,ウィンドウの矩形領域だけをキャプチャします.ここまでのサンプルでは,BitBlt 関数の第 6 引数に,デスクトップのデバイスコンテキストの値を渡していましたが,このサンプルでは,対象のウィンドウのデバイスコンテキストの値を渡しています.
キャプチャ対象のハンドルを指定すれば,コントロールや子ウィンドウでもキャプチャできます.



図39
キャプチャ画像例 1
  • フォームの BorderStyle が bsSizeable または
    bsSizeToolWin の場合
  • スクリーンの背景が白の場所でキャプチャ
図40
キャプチャ画像例 2
  • フォームの BorderStyle が bsSingle の場合
  • DwmGetWindowAttribute で取得したサイズを使用してもこの状態となる
  • サイズは取得できている.右と下部の白くなっている部分がそのサイズに含まれる
図41
Windows XP の場合
  • フォームの BorderStyle が bsSingle の場合
  • スクリーンの背景が白の場所でキャプチャ

リスト25
対象ウィンドウのデバイスコンテキストを使用した例
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.




22_PrintWindow 関数


PrintWindow 関数はある意味で便利な関数です.対象のウィンドウが他のウィンドウに隠れていても,隠れた部分の再描画を自動で実行してキャプチャできます.PrintWindow 関数では,最後の引数の値を PW_CLIENTONLY にすると,クライアント領域だけのキャプチャも可能です.
PrintWindow は,Windows XP で実装された関数です.

この PrintWindows 関数を使用したキャプチャの例です.PrintWindow 関数は 非クライアント領域の DWM の描画を実行しません.そのため非クライアント領域はスクリーン上で見えているデザインとは異なっています.
キャプチャ対象のハンドルを指定すれば,コントロールや子ウィンドウでもキャプチャできます.むしろ子ウィンドウ等のキャプチャに向いているかも知れません.



[備考]
他のプログラムのウィンドウ,つまり他のプロセスが生成したウィンドウの再描画はできません.一般的には,プロセスを超えての描画操作はできせん.
この上の GetWindowsDC 関数のサンプルのように,ウィンドウのデバイスコンテキストの内容をビットマップに描画すれば,他のウィンドウに隠れていても,クライアント領域だけの画像は取得できます.ウィンドウのフレーム部分は正常に取得できません.

画面上に表示されている,あるアプリケーションのウィンドウ (Delphi でいうフォーム) の画像を取得したいとします.しかし,上記の理由で,その画像は正常には取得できません.したがって,実際には画面,スクリーンに描画されている一部分,特定の範囲の画像だけを取得することになります.つまり,「スクリーンキャプチャ」というわけです.



図42
キャプチャ画像例 1
  • フォームの BorderStyle が bsSizeable または
    bsSizeToolWin の場合
  • スクリーンの背景が白の場所でキャプチャ
図43
キャプチャ画像例 2
  • フォームの BorderStyle が bsSingle の場合
  • DwmGetWindowAttribute で取得したサイズを使用してもこの状態となる
  • サイズは取得できている.右と下部の白くなっている部分がそのサイズに含まれる
図44
Windows XP の場合
  • フォームの BorderStyle が bsSingle の場合
  • スクリーンの背景が白の場所でキャプチャ

リスト26
PrintWindow 関数を使用したキャプチャの例
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.




23_デスクトップ上の任意の矩形範囲をキャプチャする方法


デスクトップの任意の範囲をキャプチャするには,その範囲を何らかの方法で決定します.
一般的に使用されているのは,ラバーバンドを使用する方法です.

下のコードは,デスクトップに直接描画するサンプルですが,デスクトップに描画した内容は,画面の再描画行われると,その一部または全体が消えてしまいます.ラバーバンドによる矩形領域の選択は再描画が伴います.デスクトップへの再描画はかなりのオーバヘッドがあります.したがって,かなりもたつく描画となります.

そこで,デスクトップ全体をキャプチャした画像を使用する方法がよく使われているようです.
キャプチャしたデスクトップの画像を,フォーム上の TImage 等に描画します.そのフォームをデスクトップ全体に表示します.その画像上で,ラバーバンドで選択操作をします.

もし,デスクトップに直接,マウスでラバーバンドを描画するのであれば,マウスの位置検出とマウス操作の検出には,グローバルフックが必要です.



図45
デスクトップへの直接描画
  • ディスクトップのデバイスコンテキストに描画している
  • 同じように,ウィンドウのデバイスコンテキストに対しても描画が可能
  • ただし,永続的ではない.他のウィンドウが上に重なると,その部分は消える

リスト27
デスクトップに,赤い線の四角形を描画
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.




24_デスクトップ画面の任意の矩形領域を選択


デスクトップ画面の任意の矩形領域を選択するサンプルです.コメント類は省略していますが,これまでのサンプルと,上の項目の参考リンクの記事のコード類を利用して作成しています.

グローバルホットキーの [Ctrl] + [A] でキャプチャ開始します.開始すると,画面のカーソルとが十字になります.この点からマウスの左ボタンをドラッグして矩形範囲を選択します.



図46
メインフォームの設計時画面
  • フォームのみ
図47
デスクトップ画像表示用フォーム
  • TImage のみ配置
  • デスクトップ画像をキャプチャしたら,このフォームをフルスクリーン (全画面) 表示する
図48
矩形範囲を選択中
  • マウス左ボタンを UP すると選択終了
  • [ESC] キーで中断
  • キャプチャ中のマウスカーソルは十字

リスト28
デスクトップ画面上の任意の矩形領域をキャプチャする
プロジェクトの Application.MainFormOnTaskbar の値は False
unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    Label1: TLabel;
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
  protected
    procedure WMHotKey(var Message: TWMHotKey); message WM_HOTKEY;
  private
    { Private 宣言 }
    FRegistHotKeyID : Integer;
    procedure PreviewCaptureImage(Bmp: TBitmap);
  public
    { Public 宣言 }
  end;

var
  Form1 : TForm1;

implementation

uses
  DesktopImageFormUnit,
  FormCaptureImageUnit;

{$R *.DFM}

//=============================================================================
//  メインフォーム生成時の処理
//=============================================================================
procedure TForm1.FormCreate(Sender: TObject);
var
  LSetKey   : Cardinal;
  LSetShift : Cardinal;
begin
  LSetKey  := Ord('A');
  LSetShift:= MOD_CONTROL;

  FRegistHotKeyID := GlobalAddAtom('MyCaptureTest');
  RegisterHotkey(Handle, FRegistHotKeyID, LSetShift, LSetKey);
end;

//=============================================================================
//  メインフォームが破棄される時の処理
//=============================================================================
procedure TForm1.FormDestroy(Sender: TObject);
begin
  if FRegistHotKeyID <> 0 then begin
    GlobalDeleteAtom(FRegistHotKeyID);
    UnregisterHotKey(Handle, FRegistHotKeyID);
  end;
end;

//-----------------------------------------------------------------------------
//  キャプチャ開始のホットキーが押された時の処理
//
//  キャプチャ範囲設定用の矩形を描画するための透明なフォームを生成して表示
//  そのフォームにデスクトップ全体の画像を描画する
//-----------------------------------------------------------------------------
procedure TForm1.WMHotKey(var Message: TWMHotKey);
const
  CAPTUREBLT = $40000000;
var
  LDesktopRect     : TRect;
  LScreenDC        : HDC;
  LDesktopImagForm : TForm2;
  LbmpOrigin       : TBitmap;
  LCaptureRect     : TRect;
begin
  if Message.HotKey = FRegistHotKeyID then begin

    Application.Minimize;
    ShowWindow(Application.Handle, SW_HIDE);
    Sleep(200);

    LDesktopImagForm := TForm2.Create(nil);
    try
      LDesktopImagForm.BorderStyle := bsNone;
      LDesktopRect := Screen.DesktopRect;

      LDesktopImagForm.Top         := LDesktopRect.Top;
      LDesktopImagForm.Left        := LDesktopRect.Left;
      LDesktopImagForm.Width       := LDesktopRect.Right  - LDesktopRect.Left;
      LDesktopImagForm.Height      := LDesktopRect.Bottom - LDesktopRect.Top;

      LScreenDC := GetWindowDC(GetDeskTopWindow);
      try
        LDesktopImagForm.Image1.Align := alClient;
        //デスクトップのイメージをキャプチャして操作用のフォームに表示
        //左端のX座標はデスクトップの左端のX座標
        //上端のY座標はデスクトップの上端のY座標
        BitBlt(LDesktopImagForm.Image1.Canvas.Handle,
               0,
               0,
               LDesktopImagForm.Width,
               LDesktopImagForm.Height,
               LScreenDC,
               LDesktopRect.Left,
               LDesktopRect.Top,
               SRCCOPY or CAPTUREBLT);
      finally
        Releasedc(0, LScreenDC);
      end;


      SetForegroundWindow(LDesktopImagForm.Handle);

      if LDesktopImagForm.ShowModal = mrOk then begin
        LCaptureRect := LDesktopImagForm.FCaptureRect;
        if LCaptureRect.Left > LCaptureRect.Right then begin
          LCaptureRect.Left  := LDesktopImagForm.FCaptureRect.Right;
          LCaptureRect.Right := LDesktopImagForm.FCaptureRect.Left;
        end;
        if LCaptureRect.Top > LCaptureRect.Bottom then begin
          LCaptureRect.Top    := LDesktopImagForm.FCaptureRect.Bottom;
          LCaptureRect.Bottom := LDesktopImagForm.FCaptureRect.Top;
        end;

        LbmpOrigin := TBitmap.Create;
        try
          LbmpOrigin.PixelFormat := pf32bit;

          LbmpOrigin.Width  := LCaptureRect.Right  - LCaptureRect.Left;
          LbmpOrigin.Height := LCaptureRect.Bottom - LCaptureRect.Top;

          //デスクトップのLCaptureRect領域のイメージをLbmpOriginビットマップに描画
          BitBlt(LbmpOrigin.Canvas.Handle,
                 0,
                 0,
                 LbmpOrigin.Width,
                 LbmpOrigin.Height,
                 LDesktopImagForm.Image1.Canvas.Handle,
                 LCaptureRect.Left,
                 LCaptureRect.Top,
                 SRCCOPY or CAPTUREBLT);

          Application.Restore;
          ShowWindow(Handle, SW_SHOWNA);

          PreviewCaptureImage(LbmpOrigin);
        finally
          FreeAndNil(LbmpOrigin);
        end;
      end else begin
        Application.Restore;
        ShowWindow(Handle, SW_SHOWNA);
        SetForegroundWindow(Handle);
      end;
    finally
      FreeAndNil(LDesktopImagForm);
    end;
  end;
end;

//-----------------------------------------------------------------------------
//  引数ビットマップ画像を表示するメソッド
//  Imaage1のサイズを設定して描画する場合は,Image1.AutoSizeの値をFalseにする
//-----------------------------------------------------------------------------
procedure TForm1.PreviewCaptureImage(Bmp: TBitmap);
begin
  FormCaptureImage.Image1.Picture.Bitmap := nil;
  FormCaptureImage.Image1.Picture.Bitmap := Bmp;
  FormCaptureImage.Image1.Update;

  FormCaptureImage.Show;
end;

end.


リスト29
デスクトップ画面全体をキャプチャして表示するフォーム
このフォームに配置した TImage にラバーバンドを描画する
unit DesktopImageFormUnit;

interface

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

type
  TForm2 = class(TForm)
    Image1: TImage;
    procedure FormKeyDown(Sender: TObject; var Key: Word;
      Shift: TShiftState);
    procedure Image1MouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure Image1MouseMove(Sender: TObject; Shift: TShiftState; X,
      Y: Integer);
    procedure Image1MouseUp(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure FormShow(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
  private
    { Private 宣言 }
    FStartPos : TPoint;
    FMovePos  : TPoint;
    FDrawFlg  : Boolean;
    procedure DrawRectLineOnImage(AStartPos, AEndPos: TPoint);
  public
    { Public 宣言 }
    FCaptureRect : TRect;
  end;

var
  Form2: TForm2;

implementation

{$R *.DFM}

procedure TForm2.FormShow(Sender: TObject);
begin
  Screen.Cursor := crCross;
  FDrawFlg := False;
end;

procedure TForm2.FormDestroy(Sender: TObject);
begin
  Screen.Cursor := crDefault;
end;

procedure TForm2.FormKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
begin
  if Key = VK_ESCAPE then begin
    ModalResult := mrCancel;
  end;
end;

procedure TForm2.Image1MouseDown(Sender: TObject;
  Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
  if Button = mbLeft then begin
    Image1.Canvas.Pen.Style   :=psSolid;
    Image1.Canvas.Pen.Width   :=3;
    Image1.Canvas.Pen.Color   :=clRed;
    Image1.Canvas.Brush.Style :=bsClear;

    FStartPos := Point(X,Y);
    FMovePos  := Point(X,Y);
    FDrawFlg  := True;
  end;
end;

procedure TForm2.Image1MouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
begin
  if not FDrawFlg then Exit;

  Image1.Canvas.Pen.Mode := pmNotXor;
  DrawRectLineOnImage(FStartPos,FMovePos);
  FMovePos := Point(X,Y);
  DrawRectLineOnImage(FStartPos,FMovePos);
end;

procedure TForm2.Image1MouseUp(Sender: TObject;
  Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
  if not FDrawFlg then Exit;

  if Button = mbLeft then begin
    FDrawFlg := False;
    DrawRectLineOnImage(FStartPos,FMovePos);

    FCaptureRect.TopLeft     := FStartPos;
    FCaptureRect.BottomRight := FMovePos;

    ModalResult := mrOK;
  end;
end;

procedure TForm2.DrawRectLineOnImage(AStartPos, AEndPos: TPoint);
var
  LRect : TRect;
begin
  LRect.TopLeft     := AStartPos;
  LRect.BottomRight := AEndPos;
  Image1.Canvas.Rectangle(LRect);
end;

end.




25_デスクトップ画面のクリックした 2 点で矩形範囲を選択


マウスのドラッグではなく,最初にクリックした点と,次にクリックした点の 2 点で決まる矩形領域を取得する場合は,上のサンプルの OnMouseDown イベントを使用しないで,OnMouseUp イベントのコードを,例えば次のようにします.
OnClick イベントでもできますが,OnClick イベントを使用する場合は,GetCursorPos 関数,あるいは OnMouseMove イベント内でマウスカーソル位置を取得して,それを使用することになります.

マルチモニタ環境で GetCursorPos を使用する場合は注意が必要です.本サンプルで使用しているマウスの位置を保持する変数類は,左上が (0, 0) という座標値です.一方,システムのマウスカーソルの位置は,負の値になることもあります.座標値の換算が必要です.



リスト30
最初のクリックで始点,次のクリックで終点を決定する方法の例
procedure TForm2.Image1MouseUp(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  if Button = mbLeft then begin
    if not FDrawFlg then begin
      FDrawFlg  := True;
      Image1.Canvas.Pen.Style   := psSolid;
      Image1.Canvas.Pen.Width   := 3;
      Image1.Canvas.Pen.Color   := clRed;
      Image1.Canvas.Brush.Style := bsClear;

      FStartPos := Point(X,Y);
      FMovePos  := Point(X,Y);
    end else begin
      FDrawFlg := False;
      DrawRectLineOnImage(FStartPos,FMovePos);

      FCaptureRect.TopLeft     := FStartPos;
      FCaptureRect.BottomRight := FMovePos;

      ModalResult := mrOK;
    end;
  end;
end;




26_キャプチャした画像の印刷


キャプチャしたビットマップ画像を,プリンタのキャンパスに描画すれば印刷となります.
印刷というのは,プリンタのキャンパス (TCanvas) に対して描画コードを実行することです.
TImage.Canvas に対して描画コードを実行した場合は,TImage での表示となります.
印刷だけであれば,TImage に描画する必要はありません.

描画には,Bitblt 関数や,TCanvas の関数類が使用できますが,例えば Draw メソッドで描画するとプリンタキャンパスの 1 ドットがビットマップの 1 ピクセル相当として印刷されます.そのため,プリンタの解像度によって実際に印刷されるサイズが違ってきます.

任意のサイズで画像を印刷するには,プリンタの解像度 (DPI) を取得して,プリンタの Canvas への描画位置やサイズを計算します.そして,StretchDraw メソッド,あるいは StretchBlt 関数等で描画します.
また,プリンタ設定コンポーネントのテストプログラム [ミリメートル単位で図形を描画] のような方法もあります.