Delphi Programming / Object Pascal
サイトのトップページへ リンクのページへ ロゴマーク
[掲載 2011年01月15日] [更新 2014年05月23日] Delphi サンプルプログラム集
   
822_コピーフック
動作確認等 Windows 7 U64(SP1) + Delphi XE Pro
64bit 版の DLLDelphi XE3(UP1) Pro で作成
[6] は,Windows 7 U64(SP1) + Delphi XE3(UP1) VCL-32, VCL-64
822_ShellCopyHook.zip [4,994 KB] 2014年05月23日版(同梱のEXEは,32bitアプリ)



  • 2013年02月22日
  • Windows 7 の 64bit 版でもテスト可能なコードに修正
  • コードの整備と記事の構成変更と修正
  • 2013年03月02日
  • アプリケーションマニフェストを追加
  • 2013年07月22-24日
  • Windows の 32, 64 ビット版の判定の説明に間違いがあったので,記事とコードを修正
  • 2014年04月29日
  • PE ヘッダを使用して,EXE (DLL) が 32 ビット版か 64 ビット版かを判定するサンプルを追加




ICopyHook によるコピーフック


シェルのコピーフックのテストプログラムです.
コピーフックと言うと,ファイルのコピー操作に関する検出のような印象を受けますが,実際には,システム上に存在するフォルダの,[コピー],[移動],[削除],[名前の変更]の 4 つの操作を検出し,操作の実行継続や禁止等を行うものです.対象はファイルではなく「フォルダ」だけです.

コールバック関数の定義は次のようになっています.


リスト1
コピーフックのコールバック関数の定義
UINT CopyCallback(
  [in, optional]  HWND hwnd,
                  UINT wFunc,
                  UINT wFlags,
  [in]            PCTSTR pszSrcFile,
                  DWORD dwSrcAttribs,
  [in, optional]  LPCTSTR pszDestFile,
                  DWORD dwDestAttribs
);


以下の表は,その引数の値と意味です.

確かにフォルダの削除や名前変更をされては困る場面はあるわけですが,サーバ側の設定でも可能だと思われるのですが,どうなのでしょうか.ファイルの操作もフックできるのであれば,表示するダイアログを変更する用途には利用できるとは思っています.


表1
コールバック関数内で取得できる wFunc の値

FO_COPY フォルダが [コピー] の後,[貼り付け] されようとしている
pszSrcFile がコピー元フォルダ,pszDestFile が貼り付けフォルダ
FO_DELETE フォルダが削除されようとしている
pszSrcFile が削除されるフォルダ
FO_MOVE フォルダが移動されようとしている
pszSrcFile が移動元フォルダ,pszDestFile が移動先フォルダ
FO_RENAME フォルダの名前が変更されようとしている
pszSrcFile が変更前のフォルダ,pszDestFile が変更後のフォルダ


表2
wFlags の主な値 (SHFILEOPSTRUCT Structure の fFlags 参照)
本ページのサンプルでは,これらの値の検出は行っていない

FOF_SILENT 処理の進行を示す UI を表示しない
FOF_NOERRORUI エラーが発生しても UI を表示しない
FOF_NOCONFIRMATION 確認のための UI を表示しない
全て YES で応答したことする
FOF_NOCONFIRMMKDIR 新しいフォルダ作成時に,その確認を UI で行わない
FOF_NO_UI 上記 4 つのフラグの組み合わせ
PO_DELETE プリンタが削除されようとしている
pszSrcFile は対象プリンタのフルパス
PO_RENAME プリンタ名が変更されようとしている
pszSrcFile は新しい名前,pszDestFile は前の名前
逆のような気もするが未確認


表3
コールバック関数の戻り値として指定可能な値

IDYES 操作を許可する
IDNO 操作を許可しない
IDCANCEL 操作をキャンセルする.許可しない場合との違いは未確認


このシェルコピーフックは,シェルのフォルダ操作を検出するものです.シェルによる操作とは,主にエクスプローラによる操作ということになります.
またファイル操作関係のシェル関数である SHFileOperation 関数等でフォルダを操作した場合も発生します.次のコードのように,一般のファイルシステム関係の関数を使用して操作しても,コピーフックのコールバック関数は呼ばれません.



リスト2
ファイルシステムの関数ではコピーフックは検出できない
procedure TForm1.Button3Click(Sender: TObject);
var
  SrcFile  : String;
  DestFile : String;
begin
  SrcFile  := 'D:\000';
  DestFile := 'D:\001';

  MoveFile(PChar(SrcFile), PChar(DestFile));
end;

procedure TForm1.Button4Click(Sender: TObject);
var
  ADir : String;
begin
  ADir := 'D:\001';
  RemoveDir(ADir);
end;




01_Delphi の Demos のサンプルを使用


コピーフックのサンプルが Delphi 2010 の [Demos] [ActiveX] [ShellExt] 内にあります.テストにはこれを使用することにしました.DLL 内に,COM サーバ登録と解除関係のコードが記述してあり,そのまま使用できます.
このサンプルは,Delphi XE 以降にはないようですが,最新版の Delphi ユーザは,旧バージョンも入手可能です.入手すればオリジナルのデモコードを確認することができます.

まず,デモの copyhook.dpr をコンパイルして,copyhook.dll を作成します.この dll を COM サーバとしてシステムに登録し,レジストリに情報を書き込みます.この変更は,Windows を再起動すると有効となります.登録の解除も再起動が必要です.
フックした結果は,dll 内のコールバック関数が処理します.今回のテストでは,
  • 表示する文字列を日本語に変更
  • D:\000 内のフォルダに対する操作は一切禁止
のようにコールバック関数の処理を変更しています.
DLL は 32bit 版と 64bit 版の両方作成しました.



リスト3
本テストプログラムで使用したコールバック関数のコード
function TCopyHook.CopyCallBack(Wnd: HWND; wFunc, wFlags: UINT;
  pszSrcFile: PWideChar; dwSrcAttribs: DWORD; pszDestFile: PWideChar;
  dwDestAttribs: DWORD): UINT;
var
  Operation  : String;
  SrcFile    : String;
  TargetFile : String;
  MstStr     : String;
begin
  TargetFile := UpperCase('D:\000');
  SrcFile    := UpperCase(String(pszSrcFile));

  if Pos(TargetFile, SrcFile) > 0 then begin
    MstStr := String(pszSrcFile) + sLineBreak +
              'このフォルダに対する操作は許可されていません';
    MessageBox(Wnd, PChar(MstStr), 'シェルコピーフック' , MB_OK);
    Result := IDNO;
  end else begin
    case wFunc of
      FO_COPY:
        Operation := 'コピー';
      FO_DELETE:
        Operation := '削除';
      FO_MOVE:
        Operation := '移動';
      FO_RENAME:
        Operation := '名前の変更';
      else
        Operation := ''
    end;

    MstStr := Operation + sLineBreak +
              String(pszSrcFile) + sLineBreak +
              '操作を続行しますか ? ';
    Result := MessageBox(Wnd, PChar(MstStr), 'シェルコピーフック' , MB_YESNOCANCEL);
  end;
end;




02_コピーフックをシステムに登録  -  DLL の登録


レジストリへの登録を行えば,後は DLL 内のコードが COM サーバとして登録してくれます.
登録解除も同じです.どちらもコンピュータの再起動が必要です.

このサンプルでは,32 ビット, 64 ビットのどちらのアプリでも動作するようにしました.添付している登録・登録解除用の実行ファイル (EXE) は 32 ビットのアプリケーションです.
まず,32 ビット版の DLL をシステムに登録または登録の解除をします.現在の Windows 7 が 64 ビット版であれば,続いて 64 ビット版のコマンドプロンプトを非表示で起動し,64 ビット版の DLL を登録または登録の解除をするようにしています.

このプログラムは,レジストリを操作します.したがって,実行には管理者権限 (管理者として実行) が必要です.そこで,アプリケーションマニフェストを使用しています.EXE 起動時に,下図のよう管理者への昇格確認のダイアログが表示されます.



図1
管理者として実行

図2
登録と登録解除用プログラム
  • 管理者権限での起動が必要
図3
登録
  • コンピュータの再起動が必要
図4
登録解除
  • コンピュータの再起動が必要

登録すると,レジストリに該当 GUID の名前のキーが作成され,その階層下に InprocServer32 というサブキーが作成されます.その {既定} 項目に CopyHook.dll のフルパスが記録されます.
登録を解除すると,これからのキーはレジストリから全て削除されます.

下図のように,レジストリの [ShellExtensions] にも履歴が追加されます.
このレジストリへの登録によって,DLL 内のコールバック関数が自動的にが呼出されて実行されるようになります.登録と登録解除を繰り返すと,同じ項目が履歴分に追加されます.気になるようでしたら,Delphi CopyHook Shell で検索して削除してください.



  • 図5
  • レジストリに追加された登録履歴
  • GUID と データの文字列は,DLL 内のコードを参照

64 ビット版の Windows 7 の場合は,32 ビット用のレジストリにも同様の項目が作成されます.
32 ビット用のレジストリエディタは,[コマンドプロンプト],あるいは [ファイル名を指定して実行] のダイアログから以下のコマンドで起動できます.

C:\Windows\SysWOW64\Regedit



図6
32bit 用レジストリエディタを起動

リスト4
コピーフックをシステムに登録するためのプログラム
添付の EXE は 32 ビットアプリとなっている
unit HookDllRegist32Unit;

interface

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

type
  TForm1 = class(TForm)
    Button1: TButton;
    Button2: TButton;
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
  private
    { Private 宣言 }
    DllPath32 : String;
    DllPath64 : String;
    Is64OS    : Boolean;
    function RegistSvr(AFileName: String; AMode: Boolean): Boolean;
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

//-----------------------------------------------------------------------------
//  コマンドラインのコマンドを実行する関数
//  起動完了を待たずに呼出し側に処理を戻す
//-----------------------------------------------------------------------------
function RunCommmadLine(CommandLine: string): DWORD;
var
  StartupInfo : TStartupInfo;
  ProcessInfo : TProcessInformation;
begin
  FillChar(StartupInfo, SizeOf(StartupInfo), #0);

  StartupInfo.cb      := sizeof(TStartupInfo);
  StartupInfo.dwFlags := STARTF_USESHOWWINDOW;
  //これがないとコマンドプロンプトのウィンドウが表示されてしまう
  //この指定を有効にするためには,dwFlagsにSTARTF_USESHOWWINDOWを指定する
  StartupInfo.wShowWindow := SW_HIDE;

  //参照カウンタ対策
  UniqueString(CommandLine);

  if not CreateProcess(nil,
                       PChar(CommandLine),
                       nil,
                       nil,
                       True,
                       CREATE_NEW_CONSOLE,
                       nil,
                       nil,
                       StartupInfo,
                       ProcessInfo) then begin
    Result := WAIT_FAILED
  end else begin
    GetExitCodeProcess(ProcessInfo.hProcess, Result);
    CloseHandle(ProcessInfo.hProcess);
    CloseHandle(ProcessInfo.hThread);
  end;
end;

//-----------------------------------------------------------------------------
//  32ビットのWindowsか64ビットのWindowsかを調べる関数
//  64ビット版のWindowsの場合はTrueを返す
//-----------------------------------------------------------------------------
function Is64bitWindows: Boolean;
var
  Wow64Proc : function(hProcess: THandle; var Wow64: BOOL): BOOL stdcall;
  RetFlag   : LongBool;
begin
  @Wow64Proc := GetProcAddress(GetModuleHandle('Kernel32.dll'), 'IsWow64Process');
  if @Wow64Proc <> nil then begin
    Wow64Proc(GetCurrentProcess, RetFlag);

    if SizeOf(THandle) = 4 then begin
      Result := RetFlag;
    end else
    if SizeOf(THandle) = 8 then begin
      Result := True;
    end;
  end else begin
    //XP-64bit以上
    Result := CheckWin32Version(5, 2);
  end;
end;

//=============================================================================
//  DLLのフルパスを取得しておく
//=============================================================================
procedure TForm1.FormCreate(Sender: TObject);
begin
  //32bit版のDLLのフルパス
  DllPath32 := ExtractFilePath(Application.ExeName) + 'ShellExt32';
  DllPath32 := IncludeTrailingPathDelimiter(DllPath32) + 'copyhook.dll';

  //64bit版のDLLのフルパス
  DllPath64 := ExtractFilePath(Application.ExeName) + 'ShellExt64';
  DllPath64 := IncludeTrailingPathDelimiter(DllPath64) + 'copyhook.dll';

  //64bit版のWindowsかを調査
  Is64OS := Is64bitWindows;
end;

//-----------------------------------------------------------------------------
//  環境変数(%で囲まれた文字列)から実際のパス名を取得する関数
//-----------------------------------------------------------------------------
function ExpandEnvironmentString(S: String): String;
var
  DstChar : array [0..MAX_PATH - 1] of Char;
begin
  ExpandEnvironmentStrings(PChar(S), DstChar, MAX_PATH);
  Result := DstChar;
end;

//=============================================================================
//  シェル・コピーフックの登録
//  copyhook.dllをCOMサーバーとして登録し,レジストリに登録
//  Windowsの再起動が必要
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
var
  ACmdStr : String;
  DllPath : String;
begin
  if RegistSvr(DllPath32, True) then begin
    if Is64OS then begin
      //64bit版のWindowsだったら64bit版DLLをコマンドプロンプトを起動して登録
      DllPath := AnsiQuotedStr(DllPath64, '"');
      ACmdStr := '%systemroot%\Sysnative\cmd.exe /c regsvr32.exe ';
      ACmdStr := ExpandEnvironmentString(ACmdStr) + DllPath;
      RunCommmadLine(ACmdStr);
    end;
  end else begin
    Application.MessageBox('登録に失敗しました', '情報');
  end;
end;

//=============================================================================
//  シェル・コピーフック登録解除
//  シェルの操作機能を通常に戻す
//  Windowsの再起動が必要
//=============================================================================
procedure TForm1.Button2Click(Sender: TObject);
var
  ACmdStr : String;
  DllPath : String;
begin
  if RegistSvr(DllPath32, False) then begin
    if Is64OS then begin
      //64bit版のWindowsだったら64bit版DLLをコマンドプロンプトを起動して登録解除
      DllPath := AnsiQuotedStr(DllPath64, '"');
      ACmdStr := '%systemroot%\Sysnative\cmd.exe /c regsvr32.exe /u ';
      ACmdStr := ExpandEnvironmentString(ACmdStr) + DllPath;
      RunCommmadLine(ACmdStr);
    end;
  end else begin
    Application.MessageBox('登録解除に失敗しました', '情報');
  end;
end;

//=============================================================================
//  regsvr32コマンドを使用してレジストリにDLLを登録または登録解除するのと同じ動
//  作を行う関数.レジストリの操作は管理者権限が必要
//  DLL内にCOMサーバとしての登録と登録解除のコードが実装されている
//
//  AFileName   ActiveX DLLやOCXのフルパス
//  AMode True  登録
//        False 登録解除
//=============================================================================
function TForm1.RegistSvr(AFileName: String; AMode: Boolean): Boolean;
type
  TRegProc = function : HResult; stdcall;
var
   RegProc   : TRegProc;
   LibHandle : THandle;
   AREGMODE  : String;
begin
  Result := False;

  if AMode then begin
    AREGMODE := 'DllRegisterServer';
  end else begin
    AREGMODE := 'DllUnregisterServer';
  end;

  LibHandle := LoadLibrary(PChar(AFileName));
  if  LibHandle <> 0 then begin
    try
      @RegProc := GetProcAddress(LibHandle, PChar(AREGMODE));
      if (@RegProc = nil) or (RegProc <> 0) then begin
        Result := False;
      end else begin
        Result := True;
      end;
    finally
      FreeLibrary(LibHandle);
    end;
  end;
end;

end.




03_DLL の登録をコマンドラインから行う場合


DLL や OCX をシステムに登録するには,regsvr32.exe を使用します.
DLL がある場所が D:\000\copyhook.dll の場合,コマンドプロンプトを管理者権限で起動して,次のコマンドを実行します.DLL や OCX のパス名に空白文字が含まれている場合は,パス名をダブルクオーテーション (") で囲みます.

regsvr32 D:\000\copyhook.dll     //登録
regsvr32 D:\000\copyhook.dll /u  //登録解除


コマンドプロンプトは 64 ビット版,32 ビット版のどちらであっても,DLL が 64 ビット版であっても 32 ビット版であっても,自動認識して登録あるいは登録解除をしてくれるようです.
しかし,マイクロソフトのサイトの記事や,ネット上の記事には失敗する例が掲載されています.原因については分かりません.
おそらく,以下の方法が確実と思われます.

32 ビット版の DLL や OCX の場合は,32 ビット版のコマンドプロンプトを管理者権限で起動して,32 ビット版の regsvr32.exe を使用します.
64 ビット版の DLL や OCX の場合は,64 ビット版のコマンドプロンプトを管理者権限で起動して,64 ビット版の regsvr32.exe を使用します.

コマンドラインは以下のようになりますが,実際にはリダイレクト機能が働きます.したがって,ディレクトリ部分は不要です.つまり,32 ビット版の DLL の登録も,64 ビット版の DLL の登録も,コマンドラインは同じとなります.


// 32ビット版のDLLの場合は,32ビット版のコマンドプロンプトを管理者権限で起動
%systemroot%\SysWoW64\regsvr32.exe D:\000\copyhook.dll     //32ビット版のDLLの登録
%systemroot%\SysWoW64\regsvr32.exe D:\000\copyhook.dll /u  //32ビット版のDLLの登録解除

// 64ビット版のDLLの場合は,64ビット版のコマンドプロンプトを管理者権限で起動
%systemroot%\System32\regsvr32.exe D:\000\copyhook.dll     //64ビット版のDLLの登録
%systemroot%\System32\regsvr32.exe D:\000\copyhook.dll /u  //64ビット版のDLLの登録解除



下図は 64 ビット版の Windows 7 で,32 ビット版のコマンドプロンプトを管理者権限で起動して,32 ビット版の DLL を登録した画面です.
32 ビット版のコマンドプロンプトなので,タイトルが C:\Windows\SysWOW64\cmd.exe となっています.64 ビット版のコマンドプロンプトの場合は,C:\Windows\System32\cmd.exe となります.

コマンドプロンプトの起動直後は,ディレクトリがデフォルトで C:\Windows\System32 となっています.そのままだと,System32 内の regsvr32 を探してしてしまう可能性があります.
ディレクトリを,下図のように C:\ にしてから操作した方が間違いありません.
ディレクトリを C:\ にするには,cd /d C:\ というコマンドを実行します.



図7
コマンドプロンプトから登録
  • コマンドプロンプトは管理者権限で起動する
  • ディレクトリを C:\ にしてからコマンド類を実行する

上の操作で実際にレジストリに登録されているかを確認したのが下のリストです.

64 ビット版のレジストリには,Wow6432Node という,32 ビット版のレジストリを意味する場所にしか記録されていません.一方,32 ビット版のレジストリでも,64 ビット版のレジストリにおける記録場所が分かるようになっています.



// Regedit.exe(64ビット版のレジストリエディタ) でD:\000\copyhook.dllを検索した結果

[HKEY_CLASSES_ROOT]
Wow6432Node\CLSID\{29F97553-FBD6-11D1-AFC1-00A024D1875C}\InprocServer32

[HKEY_LOCAL_MACHINE]
SOFTWARE\Classes\Wow6432Node\CLSID\{29F97553-FBD6-11D1-AFC1-00A024D1875C}\InprocServer32
SOFTWARE\Wow6432Node\Classes\CLSID\{29F97553-FBD6-11D1-AFC1-00A024D1875C}\InprocServer32


// C:\Windows\SysWOW64\RegeditでD:\000\copyhook.dllを検索した結果
// C:\Windows\SysWOW64\Regeditは32ビット版のレジストリエディタ

[HKEY_CLASSES_ROOT]
CLSID\{29F97553-FBD6-11D1-AFC1-00A024D1875C}\InprocServer32
Wow6432Node\CLSID\{29F97553-FBD6-11D1-AFC1-00A024D1875C}\InprocServer32

[HKEY_LOCAL_MACHINE]
SOFTWARE\Classes\CLSID\{29F97553-FBD6-11D1-AFC1-00A024D1875C}\InprocServer32
SOFTWARE\Classes\Wow6432Node\CLSID\{29F97553-FBD6-11D1-AFC1-00A024D1875C}\InprocServer32


32 ビット版の Windows 7 では,以下の場所に記録されます.
64 ビット版の Windows 7 で,64 ビット版の DLL を登録した場合も同じ場所に記録されます.


[HKEY_CLASSES_ROOT]
CLSID\{29F97553-FBD6-11D1-AFC1-00A024D1875C}\InprocServer32

[HKEY_LOCAL_MACHINE]
SOFTWARE\Classes\CLSID\{29F97553-FBD6-11D1-AFC1-00A024D1875C}\InprocServer32



[備考]
64 ビット版の Windows の場合,32 ビットの EXE からは,ディレクトリに C:\Windows\System32 を指定しても,32 ビット版のプログラムが起動するようになっています.例えば 32 ビット版のコマンドプロンプトで
     C:\Windows\System32\calc.exe
としても,32 ビット版の電卓が起動します ([ファイル名を指定して実行] のダイアログでは当然 64 ピッ版の電卓が起動します).
regsvr32.exe が,DLL が 32 ビットでも 64 ビットでも登録できるというのは,regsvr32.exe 特有の機能なのかも知れませんが,少々理解しにくい仕様のような感じがします.マイクロソフトの「親切」なのかも知れませんが,一貫性があるとは思えません.




04_コピーフックの実行例


フォルダの操作を禁止した D:\000 内のフォルダ内のフォルダを削除しようとした場合の例です.
まず,通常の確認ダイアログが表示されます.ここで,[はい] を選択しても,コピーフック内で定義したダイアログが現れて,操作ができないようになっています.


図8
フォルダの削除
  • 通常のダイアログが表示される
図9
禁止


その他のフォルダを [コピー] して,他のフォルダに [貼り付け] 操作を行った場合です.
[コピー] 操作ではなく,実際のコピー,つまり,[貼り付け] の時に表示されます.


図10
[貼り付け] の時に表示される




05_Windows が 32 ビット版 か 64 ビット版かの判定


現在のシステムの Windows が 32 ビット版か 64 ビット版かを判定するため,本サンプルでは以下のような関数を作成して使用しています.
IsWow64Process は,Windows XP(SP2) より前にはありません.そこで,CheckWin32Version で判定しています.Windows 2000 は 64 ビット版が発表はされましたが,実際には普及しなかったようですから,32 ビット版だけと考えていいでしょう.
Delphi 6 では,この CheckWin32Version 関数の戻り値が Delphi 7 以降と異なる場合があります.下記の参考リンクの ID: 17706 をダウンロードして使用してください.



//-----------------------------------------------------------------------------
//  32ビットのWindowsか64ビットのWindowsかを調べる関数
//  64ビット版のWindowsの場合はTrueを返す
//-----------------------------------------------------------------------------
function Is64bitWindows: Boolean;
var
  Wow64Proc : function(hProcess: THandle; var Wow64: BOOL): BOOL stdcall;
  RetFlag   : LongBool;
begin
  @Wow64Proc := GetProcAddress(GetModuleHandle('Kernel32.dll'), 'IsWow64Process');
  if @Wow64Proc <> nil then begin
    Wow64Proc(GetCurrentProcess, RetFlag);

    if SizeOf(THandle) = 4 then begin
      Result := RetFlag;
    end else
    if SizeOf(THandle) = 8 then begin
      Result := True;
    end;
  end else begin
    //Windows XPの64ビット版か
    Result := CheckWin32Version(5, 2);
  end;
end;

//=============================================================================
//  上の関数のテスト
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
begin
  if Is64bitWindows then begin
    MessageBox(Handle, '64 ビット Windows です', '情報', MB_OK or MB_ICONASTERISK);
  end else begin
    MessageBox(Handle, '32 ビット Windows です', '情報', MB_OK or MB_ICONASTERISK);
  end;
end;


現在のシステムの Windows が 32 ビット版か 64 ビット版かは,WMI でも取得できます.
Win32_OperatingSystem クラスのクエリーを実行すると,現在のオペレーティングシステムの情報が取得できます.この中の OSArchitecture がビット数を表わしています.また,CSDVersion が サービスパックの内容となっています.

下図は,その下のコードの実行結果です.結果は文字列として取得することになりますから,その文字列の中に 64 か 32 の文字例があるかで判定できます.
WMI による情報の取得は,基本的に Windows のバージョンに依存しませんが,Windows の古いバージョンでは実装されていないプロパティがあります.例えば,MSDN の Win32_OperatingSystem class の説明によると OSArchitecture は,

    Windows Server 2003 and Windows XP: This property is not available.

となっていて,Windows XP では検出できません.



図11
OS のビット数
図12
サービスパックの情報


//=============================================================================
//  WMIを使用してWindowsのビットバージョンを取得
//  Win32_OperatingSystemクラスでは,OSの各種情報が取得できる
//
//  usesにActiveXが必要
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
var
  strQuery       : String;
  EnumCollection : IEnumVariant;
  CollectionItem : OleVariant;
  Value          : LongWord;
  ACount         : Integer;
  StrText        : String;
begin
  strQuery := 'Select * From Win32_OperatingSystem';
  //クエリーを実行してプロパティセットのコレクションを取得
  EnumCollection := GetPropertyEnumCollection(strQuery, ACount);

  //プロパティの値を取得して表示
  //Win32_OperatingSystemのプロパティセットは1組だけ
  if EnumCollection.Next(1, CollectionItem, Value) = S_OK then begin
    //OSのビットバージョン
    StrText := String(CollectionItem.OSArchitecture);
    MessageBox(Handle, PChar(StrText), '情報', MB_ICONASTERISK);
    //サービスパックの種類
    StrText := String(CollectionItem.CSDVersion);
    MessageBox(Handle, PChar(StrText), '情報', MB_ICONASTERISK);
  end;
end;

//=============================================================================
//  Wbemのオブジェクトを生成して指定引数で接続してクエリーを実行
//  プロパティセットのコレクションを取得して返す関数
//  クエリー文は引数のstrQueryで指定する
//
//  [901_WMI を使用したソフトウェア関係情報の取得]の同名関数と全く同じ
//  usesにWbemScripting_TLB(タイプライブラリの取り込みで作成)が必要
//=============================================================================
function TForm1.GetPropertyEnumCollection(strQuery: String;
  var Count: Integer): IEnumVariant;
var
  strSever       : String;
  strNameSpace   : String;
  strUser        : String;
  strPassword    : String;
  strLocale      : String;
  strAuthority   : String;
  iSecurityFlags : Integer;
  Locator        : SWbemLocator;
  Service        : SWbemServices;
  PropObjectSet  : SWbemObjectSet;
begin
  Result := nil;
  Count  := 0;

  strSever     := '.';           //PC名.ローカルPCの場合は'.'
  strNameSpace := 'root\cimv2';  //名前空間.空文字でも可
  strUser      := '';            //管理権限者名.ローカルPCの場合は要空文字
  strPassword  := '';            //パスワード.ローカルPCの場合は要空文字
  strLocale    := '';            //実行地域コード(米ならMS_409).空白は現地域
  strAuthority := '';            //ドメイン名'ntlmdomain:DOMAIN'のように指定
                                 //ドメイン無しかローカルPCの場合は要空文字
  iSecurityFlags := 0;           //常に0


  //Wbemのオブジェクトを生成して指定引数で接続
  Locator := CoSWbemLocator.Create;

  try
    Service := Locator.ConnectServer(strSever,
                                    strNameSpace,
                                    strUser,
                                    strPassword,
                                    strLocale,
                                    strAuthority,
                                    iSecurityFlags,
                                    nil);
    //プロパティのセットのオブジェクトを取得
    PropObjectSet := Service.ExecQuery(strQuery,
                                       'WQL',
                                       wbemFlagReturnImmediately,
                                       nil);

    //プロパティのセットのコレクションを列挙
    Result := PropObjectSet._NewEnum as IEnumVariant;
    //ExecQueryのフラグにwbemFlagForwardOnlyを含めるとcountプロパティはエラー
    //ただしクエリーの実行は速くなる
    Count := PropObjectSet.count;
  except
    on ex: Exception do
      ShowMessage(ex.Message);
  end;
end;




06_32 ビットアプリから 64 ビット版のコマンドプロンプトを起動


コピーフックをシステムに登録,あるいは登録解除する際に,64 ビット版のコマンドプロンプトを非表示で起動しています.

32 ビットのアプリから 64 ビットの System32 内のファイルにアクセスする場合, 以下のように,仮想ディレクトリの Sysnative にアクセスします.あるいは,リダイレクトの機能を無効化します.そうしないと,リダイレクト機能により,32 ビット用のファイルが呼出されてしまいます.
この仮想ディレクトリ Sysnative は,64 ビットのアプリでは使用できません (ありません).64 ビットアプリでは,実ディレクトリである System32 を使用します.

ディレクトリ System32 は 32 ビット版の Windows のシステムフォルダです.System32 は,32 という名前が付いていますが,64 ビット版の Windows では 64 ビット用のシステムフォルダです.



  %systemroot%\Sysnative\cmd.exe  または

  %windir%\Sysnative\cmd.exe


逆に,64 ビットアプリケーションから,32 ビット版のコマンドプロンプトを起動するには,次のように SysWOW64 を指定します.SysWOW64 は,64 ビット版の Windows における 32 ビット版のシステムフォルダとなっています.SysWOW64 は,32 ビット版の Windows にはありません.
以下の値は,デフォルトでは,C:\Windows\SysWOW64\cmd.exe となります.


  %systemroot%\SysWOW64\cmd.exe  または

  %windir%\SysWOW64\cmd.exe


実際のアプリケーションでは,以下のように,実行環境の Windows が 32 ビットか 64 ビットかの判定が必要です.


implementation

uses
  ShellAPI;

{$R *.DFM}
//-----------------------------------------------------------------------------
//  32ビットのWindowsか64ビットのWindowsかを調べる関数
//  64ビット版のWindowsの場合はTrueを返す
//-----------------------------------------------------------------------------
function Is64bitWindows: Boolean;
var
  Wow64Proc : function(hProcess: THandle; var Wow64: BOOL): BOOL stdcall;
  RetFlag   : LongBool;
begin
  @Wow64Proc := GetProcAddress(GetModuleHandle('Kernel32.dll'), 'IsWow64Process');
  if @Wow64Proc <> nil then begin
    Wow64Proc(GetCurrentProcess, RetFlag);

    if SizeOf(THandle) = 4 then begin
      Result := RetFlag;
    end else
    if SizeOf(THandle) = 8 then begin
      Result := True;
    end;
  end else begin
    //Windows XPの64ビット版か
    Result := CheckWin32Version(5, 2);
  end;
end;

//=============================================================================
//  コマンドプロンプトの起動
//  64ビットWindowsでは常に64ビット版のコマンドプロンプトを起動する方法
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
var
  LCmdExe   : string;
  LCmdParam : string;
begin
  //64ビットWindowsの場合で自分自身が32ビットEXEの時
  if (Is64bitWindows) and (SizeOf(Pointer) = 4) then begin
    LCmdExe := 'C:\windows\Sysnative\cmd.exe';
  end else begin
    LCmdExe := 'cmd.exe';
  end;
  LCmdParam := '/k';

  ShellExecute(0, nil, PChar(LCmdExe), PChar(LCmdParam), nil, SW_SHOWNORMAL);
end;

//=============================================================================
//  コマンドプロンプトの起動
//  64ビットWindowsでは常に32ビット版のコマンドプロンプトを起動する方法
//=============================================================================
procedure TForm1.Button2Click(Sender: TObject);
var
  LCmdExe   : string;
  LCmdParam : string;
begin
  //64ビットWindowsの場合で自分自身が64ビットEXEの時
  if (Is64bitWindows) and (SizeOf(Pointer) = 8) then begin
    LCmdExe := 'C:\windows\SysWOW64\cmd.exe';
  end else begin
    LCmdExe := 'cmd.exe';
  end;
  LCmdParam := '/k';

  ShellExecute(0, nil, PChar(LCmdExe), PChar(LCmdParam), nil, SW_SHOWNORMAL);
end;

end.




07_アプリが 32 ビットか 64 ビット版かを判定する方法


サンプルの DLL 登録用のプログラムは,32 ビットのプロジェクトとして作成していますので,必要ありませんが,アプリケーションが 32 ビットか 64 ビット版かを判定する場合,次のような状況が考えられます.
  • 自分自身が 32 ビットアプリか 64 ビットアプリか
  • 任意の実行可能なファイルが 32 ビット版か 64 ビット版か
  • 現在起動中の,自アプリ以外のアプリが 32 ビットアプリか 64 ビットアプリか
自分自身が 32 ビットアプリか 64 ビットアプリかは,NativeInt のサイズやポインタのサイズで調べることができます.32 ビットアプリのポインタのサイズは 4 バイト,64 ビットアプリのポインタのサイズは 8 バイトです.

実行形式のファイルが 32 ビット版か 64 ビット版かは,GetBinaryType 関数の引数の戻り値で判定できます.SCS_64BIT_BINARY の時が 64 ビットアプリです.この定数名は Delphi XE2 以前には定義がありません.Delphi XE3 にはあります.
EXE ファイル,または DLL ファイルが 32 ビット版か 64 ビット版かは,PE ヘッダの情報からも取得できます.

現在起動中のアプリが 32 ビット版か 64 ビット版かは,起動中のアプリのフルパスを取得すれば,実行形式のアプリの判定と同じように,GetBinaryType 関数で判定できます.
また,起動中のアプリのプロセスのハンドルを取得すれば,プロセスのハンドルから,IsWow64Process 関数を使用して判定できます.
IsWow64Process 関数は,Delphi XE2 で実装されています.それより前のバージョンにはありません.利用者が定義して使用することになります.


[備考]
GetBinaryType 関数で指定するパス名が,システム関係フォルダの場合,ファイルシステムのリダイレクト機能が働きます.したがって,32 ビットアプリで GetBinaryType を実行すると,結果は常に 32 ビットアプリとなります.また,64 ビットアプリでは常に 64 ビットアプリとなります.
これを回避して,正しい結果を得るには,ファイルシステムのリダイレクト機能を無効にして実行する必要があります.

DLL ファイルの場合,ファイルシステムのリダイレクトの機能を無効にしても,システム関係フォルダ内の DLL は,GetBinaryType 関数では正しく検出できないことがあります.
後述の PE ヘッダを使用するサンプルを参考にしてください.


図13
設計時画面
図14
32 ビット版のアプリの場合
  • 自分自身を検査した結果
図15
64 ビット版のアプリの場合
  • EXE ファイルを検査した結果

リスト5
アプリケーションが 32 ビット版か 64 ビット版かを判定する
Windows Vista 以降専用 (正確には Windows XP(SP2) 以降専用)
unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    Button1: TButton;
    Button2: TButton;
    Button3: TButton;
    Button4: TButton;
    OpenDialog1: TOpenDialog;
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure Button3Click(Sender: TObject);
    procedure Button4Click(Sender: TObject);
  private
    { Private 宣言 }
    InitDir : String;
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

//=============================================================================
//  自分自身が32bit版か64bit版かを判定
//  NativeIntのサイズで判定
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
var
  ByteSize : Integer;
begin
  ByteSize := SizeOf(NativeInt);

  if ByteSize = 4 then begin
    MessageBox(Handle, '32 ビットアプリです', '情報', MB_OK or MB_ICONASTERISK);
  end else
  if ByteSize = 8 then begin
    MessageBox(Handle, '64 ビットアプリです', '情報', MB_OK or MB_ICONASTERISK);
  end else begin
    MessageBox(Handle, '特定できません', '情報', MB_OK or MB_ICONASTERISK);
  end;
end;

//=============================================================================
//  自分自身が32bit版か64bit版かを判定
//  Pointerのサイズで判定
//=============================================================================
procedure TForm1.Button2Click(Sender: TObject);
var
  ByteSize : Integer;
begin
  ByteSize := SizeOf(Pointer);

  if ByteSize = 4 then begin
    MessageBox(Handle, '32 ビットアプリです', '情報', MB_OK or MB_ICONASTERISK);
  end else
  if ByteSize = 8 then begin
    MessageBox(Handle, '64 ビットアプリです', '情報', MB_OK or MB_ICONASTERISK);
  end else begin
    MessageBox(Handle, '特定できません', '情報', MB_OK or MB_ICONASTERISK);
  end;
end;

//=============================================================================
//  実行形式(EXE)が32bit版か64bit版かを判定
//  GetBinaryType関数を利用
//
//  SCS_32BIT_BINARY等の定数名は,Delphi XE3では実装されている
//=============================================================================
procedure TForm1.Button3Click(Sender: TObject);
const
  SCS_32BIT_BINARY = 0;
  SCS_64BIT_BINARY = 6;

var
  FileFullPath : String;
  RetFlag      : LongBool;
  BinType      : Cardinal;
begin
  if InitDir = EmptyStr then begin
    InitDir := ExtractFileDir(Application.ExeName);
  end;

  OpenDialog1.InitialDir := InitDir;
  OpenDialog1.Filter     := '実行形式ファイル|*.exe';
  if not OpenDialog1.Execute then exit;

  FileFullPath := OpenDialog1.FileName;
  InitDir      := ExtractFileDir(FileFullPath);

  RetFlag := GetBinaryType(PChar(FileFullPath), BinType);

  if RetFlag then begin
    if BinType = SCS_32BIT_BINARY then begin
      MessageBox(Handle, '32 ビットアプリです', '情報', MB_OK or MB_ICONASTERISK);
    end else
    if BinType = SCS_64BIT_BINARY then begin
      MessageBox(Handle, '64 ビットアプリです', '情報', MB_OK or MB_ICONASTERISK);
    end else begin
      MessageBox(Handle, '特定できません', '情報', MB_OK or MB_ICONASTERISK);
    end;
  end else begin
    MessageBox(Handle, '特定できません', '情報', MB_OK or MB_ICONASTERISK);
  end;
end;

//=============================================================================
//  起動中のプロセスが32bit版か64bit版かを判定
//  IsWow64Process関数を利用
//  Windows XP(SP2)以上専用
//  ここでは,自分自身のプロセスのハンドルで,自分自身を判定
//
//  IsWow64Process関数は,Delphi XE2には実装されている
//=============================================================================
procedure TForm1.Button4Click(Sender: TObject);
var
  IsWow64Process : function(hProcess: THandle; var Wow64Process: BOOL): BOOL stdcall;
  RetFlag        : LongBool;
begin
  @IsWow64Process := GetProcAddress(GetModuleHandle('Kernel32.dll'), 'IsWow64Process');

  if @IsWow64Process = nil then begin
    MessageBox(Handle, '特定できません', '情報', MB_OK or MB_ICONASTERISK);
  end else begin
    IsWow64Process(GetCurrentProcess, RetFlag);

    if RetFlag then begin
      MessageBox(Handle, '32 ビットアプリです', '情報', MB_OK or MB_ICONASTERISK);
    end else begin
      MessageBox(Handle, '64 ビットアプリです', '情報', MB_OK or MB_ICONASTERISK);
    end;
  end;
end;

end.




08_EXE ( DLL ) の 32 ビットと 64 ビットの判定 - PE ヘッダを使用


実行形式ファイルである EXE が 32 ビットか 64 ビットのアプリであるかは,PE ヘッダからも取得できます.PE ヘッダからは DLL が 32 ビット版か 64 ビット版かも取得できます.ファイルシステムのリダイレクト機能を無効にすれば,システムフォルダ内の EXE, DLL の判定も可能です.

IMAGE_OPTIONAL_HEADER 構造体の Subsystemメンバの値を調べると,バイナリファイルが,デバイスドライバであるか,コンソールアプリケーションであるかどうかも知ることができます.

PE ヘッダ (Portable Executable Header) は,EXE や DLL のヘッダ部に書き込まれているファイルの情報で,複数の構造体 (レコード型) で構成されています.本サンプルは,この構造体の一部のメンバの値を取得するサンプルとなっています.他のメンバの値を取得するテストも追加できるように,結果は TMemo に表示します.


[備考]
DLL が 32 ビット版か 64 ビット版を判定する方法として,LoadLibrary を実行して,DLL のハンドルを取得する方法があります.32 ビットのアプリでは 64 ビット版の DLL のハンドルの取得に失敗します.また,64 ビットのアプリでは 32 ビット版の DLL のハンドルの取得に失敗します.このことを利用することができます.
ただし,32 ビットアプリの場合,リダイレクトの機能を無効にしても,System32 と SysWOW64 の両方に同じ名前の DLL がある場合,LoadLibrary は,SysWOW64 内の DLL をロードします.
また,LoadLibrary は,実際に DLL のロードに失敗した場合もハンドルの取得に失敗します.したがって,DLL の存在確認が別に必要となるでしょう.



下図が,設計時の画面と実行結果の例です.
2 番目の値は CPU の特性値ではありません.ファイルイメージの特性としての値です.


図16
設計時画面
図17
64 ビットの Shell32.dll の場合
図18
32 ビットの Shell32.dll の場合
図19
64 ビット版の電卓の場合
図20
本ページのサンプルの copyhook.dll
図21
Delphi XE の bds.exe の場合
図22
32 ビットのコンソールアプリの場合


リスト6
EXE (DLL) の情報取得を PE ヘッダから取得
unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    Button1: TButton;
    Memo1: TMemo;
    OpenDialog1: TOpenDialog;
    procedure Button1Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
  private
    { Private 宣言 }
    InitDir : String;
    procedure FileHeader_Read(const Header: IMAGE_FILE_HEADER; Memo: TMemo);
    procedure OptionalHeader_Read(const Header: IMAGE_OPTIONAL_HEADER; Memo: TMemo);
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

//=============================================================================
//  フォーム生成時の処理
//  システムフォルダ内も正確にビットを取得するために,
//  ファイルシステムのリダイレクト機能を無効にしておく
//=============================================================================
procedure TForm1.FormCreate(Sender: TObject);
var
  Wow64DisableProc : function(var flgRedirec: LongBool): LongBool; stdcall;
  DirectFlag : LongBool;
begin
  @Wow64DisableProc := GetProcAddress(GetModuleHandle('Kernel32.dll'),
                                      'Wow64DisableWow64FsRedirection');
  if @Wow64DisableProc <> nil then begin
    Wow64DisableProc(DirectFlag);
  end;
end;

//=============================================================================
//  EXEまたはDLLが32ビットか64ビットかを判定 - PEヘッダから取得
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
var
  FileFullPath        : String;
  FStream             : TFilestream;
  DummyData           : DWORD;
  HeaderInfo_DOS      : IMAGE_DOS_HEADER;
  HeaderInfo_FILE     : IMAGE_FILE_HEADER;
  HeaderInfo_OPTIONAL : IMAGE_OPTIONAL_HEADER;
begin
  if InitDir = EmptyStr then begin
    InitDir := ExtractFileDir(Application.ExeName);
  end;

  OpenDialog1.InitialDir := InitDir;
  OpenDialog1.Filter     := 'ファイル|*.exe;*.dll';

  if OpenDialog1.Execute then begin
    FileFullPath := OpenDialog1.FileName;
    InitDir      := ExtractFileDir(FileFullPath);

    Memo1.Clear;
    //ファイルストリームを生成
    FStream := TFilestream.Create(FileFullPath, fmOpenread or fmShareDenyNone);
    try
      Memo1.Lines.Add(' ' + ExtractFileName(FileFullPath));

      //IMAGE_DOS_HEADERの情報をHeaderInfo_DOSレコード型に読み込む
      FStream.Read(HeaderInfo_DOS, SizeOf(HeaderInfo_DOS));

      //IMAGE_FILE_HEADER部の先頭に移動するための位置移動
      FStream.Seek(HeaderInfo_DOS._lfanew, soFromBeginning);
      FStream.Read(DummyData, SizeOf(DummyData));

      //IMAGE_FILE_HEADERの情報をHeaderInfo_FILEレコード型に読み込む
      FStream.Read(HeaderInfo_FILE, SizeOf(HeaderInfo_FILE));
      //その情報をTMemoに表示する
      FileHeader_Read(HeaderInfo_FILE, Memo1);

      //一応IMAGE_OPTIONAL_HEADERの存在を確認
      if HeaderInfo_FILE.SizeOfOptionalHeader > 0 then begin
        //IMAGE_OPTIONAL_HEADER部の情報をHeaderInfo_OPTIONALレコード型に読み込む
        FStream.Read( HeaderInfo_OPTIONAL, SizeOf(HeaderInfo_OPTIONAL));
        //その情報をTMemoに表示する
        OptionalHeader_Read(HeaderInfo_OPTIONAL, Memo1);
      end;
    finally
      FStream.Free;
    end;

  end;
end;

//-----------------------------------------------------------------------------
//  PEのIMAGE_FILE_HEADERレコードのメンバーの値を取得してTMemoに表示
//  ここでは,Machineメンバーの値とCharacteristicsメンバーの値のみ取得
//-----------------------------------------------------------------------------
procedure TForm1.FileHeader_Read(const Header: IMAGE_FILE_HEADER; Memo: TMemo);
const
  //Delphi XE2以降では不要
  IMAGE_FILE_MACHINE_IA64  = $0200;
  IMAGE_FILE_MACHINE_AMD64 = $8664;
begin
  case Header.Machine of
    IMAGE_FILE_MACHINE_I386:  Memo.Lines.Add( ' Intel 386 (x86) or later' );
    IMAGE_FILE_MACHINE_IA64:  Memo.Lines.Add( ' Intel Itanium' );
    IMAGE_FILE_MACHINE_AMD64: Memo.Lines.Add( ' AMD 64 (x64)' );
  end;

  if (IMAGE_FILE_DLL and Header.Characteristics) <> 0 then begin
    Memo.Lines.Add(' DLL file');
  end else
  if (IMAGE_FILE_EXECUTABLE_IMAGE and Header.Characteristics) <> 0 then begin
    Memo.Lines.Add(' EXE file' );
  end else begin
    Memo.Lines.Add(' Unknown file');
  end;
end;

//-----------------------------------------------------------------------------
//  PEのIMAGE_OPTIONAL_HEADERレコードのメンバーの値を取得してTMemoに表示
//  ここでは,Magicメンバーの値のみ取得
//  MagicはEXEまたはDLLが32ビット版か64ビット版かの値
//-----------------------------------------------------------------------------
procedure TForm1.OptionalHeader_Read(const Header: IMAGE_OPTIONAL_HEADER;
  Memo: TMemo);
const
  //Delphi XE2以降では不要
  IMAGE_NT_OPTIONAL_HDR32_MAGIC = $010B;
  IMAGE_NT_OPTIONAL_HDR64_MAGIC = $020B;
var
  MajorVer : String;
  MinorVer : String;
begin
  //リンカーのバージョン
  MajorVer := IntToStr( Header.MajorLinkerVersion);
  MinorVer := IntToStr( Header.MinorLinkerVersion);
  Memo.Lines.Add(' LinkerVersion : ' + MajorVer + '.' + MinorVer);

  if (Header.Magic = IMAGE_NT_OPTIONAL_HDR32_MAGIC) then begin
    Memo.Lines.Add(' IMAGE_NT_OPTIONAL_HDR32_MAGIC');
  end else
  if (Header.Magic = IMAGE_NT_OPTIONAL_HDR64_MAGIC) then begin
    Memo.Lines.Add(' IMAGE_NT_OPTIONAL_HDR64_MAGIC');
  end;

  //コンソールアプリケーションの場合
  if Header.Subsystem = IMAGE_SUBSYSTEM_WINDOWS_CUI then begin
    Memo.Lines.Add(' Subsystem : CONSOLE Application');
  end;
end;

end.




09_EXE (DLL) の 32 ビットと 64 ビットの判定 - ImageNtHeader 関数


PE ヘッダ内の情報の取得には,前項と同じ方法も使えますが,Windows API には,PE ヘッダを操作するための関数類があります.それらは ImageHlp.pas 内で定義されています.この中の ImageNtHeader という関数を使用したサンプルです.
特定の構造体の,特定のメンバーの値だけを取得したい場合は,ImageNtHeader 関数を使用すると便利です.

ImageNtHeader 関数を使用すると,PE ヘッダの先頭ポインタが取得できます.そのためには,ファイルを読み込んだ時の先頭アドレスが必要です.これは,メモリマップドファイルを生成して取得しています.メモリマップドファイルは,ファイルハンドルから生成します.
TMemoryStream や TFileStream は,シーケンシャルなアクセスに向いていますが,メモリマップドファイルは,メモリにロードしたオブジェクトの構造が分かっている場合,ランダムにメモリ内をアクセスするのに適しています.

設計時の画面は前項のサンプルと同じです.実行結果も前項のサンプルと全く同じになります.




リスト7
EXE (DLL) の情報取得 - PE ヘッダの取得に ImageNtHeader 関数を使用する例
unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    Button1: TButton;
    Memo1: TMemo;
    OpenDialog1: TOpenDialog;
    procedure Button1Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
  private
    { Private 宣言 }
    InitDir : String;
    function GetFileHeaderInfo(FileHandle: THandle): Boolean;
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

uses ImageHlp;

{$R *.dfm}

//=============================================================================
//  フォーム生成時の処理
//  システムフォルダ内も取得するために,
//  ファイルシステムのリダイレクト機能を無効にしておく
//=============================================================================
procedure TForm1.FormCreate(Sender: TObject);
var
  Wow64DisableProc : function(var flgRedirec: LongBool): LongBool; stdcall;
  DirectFlag : LongBool;
begin
  @Wow64DisableProc := GetProcAddress(GetModuleHandle('Kernel32.dll'),
                                      'Wow64DisableWow64FsRedirection');
  if @Wow64DisableProc <> nil then begin
    Wow64DisableProc(DirectFlag);
  end;
end;

//=============================================================================
//  EXEまたはDLLが32ビットか64ビットかを判定 - PEヘッダから取得
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
var
  FileFullPath : String;
  FileHandle   : THandle;
begin
  if InitDir = EmptyStr then begin
    InitDir := ExtractFileDir(Application.ExeName);
  end;

  OpenDialog1.InitialDir := InitDir;
  OpenDialog1.Filter     := 'ファイル|*.exe;*.dll';

  if OpenDialog1.Execute then begin
    FileFullPath := OpenDialog1.FileName;
    InitDir      := ExtractFileDir(FileFullPath);

    Memo1.Clear;
    Memo1.Lines.BeginUpdate;

    FileHandle := CreateFile(PChar(FileFullPath),
                             GENERIC_READ,
                             FILE_SHARE_READ,
                             nil,
                             OPEN_EXISTING,
                             FILE_ATTRIBUTE_NORMAL,
                             0);
    if FileHandle = INVALID_HANDLE_VALUE then exit;
    try
      GetFileHeaderInfo(FileHandle);
    finally
      CloseHandle(FileHandle);
    end;
    Memo1.Lines.EndUpdate;
  end;
end;

//-----------------------------------------------------------------------------
//  PEヘッダからEXEやDLLが32ビット版か64ビット版かを調べる
//  ImageHlp.pasのImageNtHeader関数でヘッダのポインタを取得する方法
//  そのために,ファイルハンドルを引数にしている
//-----------------------------------------------------------------------------
function TForm1.GetFileHeaderInfo(FileHandle: THandle): Boolean;
const
  IMAGE_FILE_MACHINE_IA64       = $0200;
  IMAGE_FILE_MACHINE_AMD64      = $8664;
  IMAGE_NT_OPTIONAL_HDR32_MAGIC = $010B;
  IMAGE_NT_OPTIONAL_HDR64_MAGIC = $020B;
var
  HeaderHandle    : THandle;
  HeaderPointer   : Pointer;
  NTHeaders       : PImageNtHeaders;
  Characteristics : Integer;
  MajorVer        : String;
  MinorVer        : String;
  Magic           : WORD;
  Subsystem       : WORD;
begin
  Result := False;

  //メモリマップドファイル生成
  //ファイルハンドルからファイルのマッピングオブジェクトを取得
  HeaderHandle := CreateFileMapping(FileHandle, nil, PAGE_READONLY, 0, 0, nil);
  if HeaderHandle = 0 then exit;
  try
    //メモリマップドファイルをアドレス空間にマップ
    //戻り値は開始アドレス
    HeaderPointer := MapViewOfFile(HeaderHandle, FILE_MAP_READ, 0, 0, 0);
    if not Assigned(HeaderPointer) then exit;
    try
      //ヘッダのポインタを取得
      NTHeaders := ImageNtHeader(HeaderPointer);
      if not Assigned(NTHeaders) then exit;

      //PEヘッダ(EXE,DLLファイル)であるかを確認
      if Trim(String(PAnsiChar(@NTHeaders.Signature))) <> 'PE' then exit;


      case NTHeaders.FileHeader.Machine of
        IMAGE_FILE_MACHINE_I386:  Memo1.Lines.Add( ' Intel 386 (x86) or later' );
        IMAGE_FILE_MACHINE_IA64:  Memo1.Lines.Add( ' Intel Itanium' );
        IMAGE_FILE_MACHINE_AMD64: Memo1.Lines.Add( ' AMD 64 (x64)' );
      end;

      Characteristics := NTHeaders.FileHeader.Characteristics;
      if (IMAGE_FILE_DLL and Characteristics) <> 0 then begin
        Memo1.Lines.Add(' DLL file');
      end else
      if (IMAGE_FILE_EXECUTABLE_IMAGE and Characteristics) <> 0 then begin
        Memo1.Lines.Add(' EXE file' );
      end else begin
        Memo1.Lines.Add(' Unknown file');
      end;


      //リンカーのバージョン
      MajorVer := IntToStr(NTHeaders.OptionalHeader.MajorLinkerVersion);
      MinorVer := IntToStr(NTHeaders.OptionalHeader.MinorLinkerVersion);
      Memo1.Lines.Add(' LinkerVersion : ' + MajorVer + '.' + MinorVer);

      Magic := NTHeaders.OptionalHeader.Magic;
      if (Magic = IMAGE_NT_OPTIONAL_HDR32_MAGIC) then begin
        Memo1.Lines.Add(' IMAGE_NT_OPTIONAL_HDR32_MAGIC');
      end else
      if (Magic = IMAGE_NT_OPTIONAL_HDR64_MAGIC) then begin
        Memo1.Lines.Add(' IMAGE_NT_OPTIONAL_HDR64_MAGIC');
      end;

      Subsystem := NTHeaders.OptionalHeader.Subsystem;
      //コンソールアプリケーションの場合
      if Subsystem = IMAGE_SUBSYSTEM_WINDOWS_CUI then begin
        Memo1.Lines.Add(' Subsystem : CONSOLE Application');
      end;
    finally
      UnmapViewOfFile(HeaderPointer);
    end;
  finally
    CloseHandle(HeaderHandle);
  end;
  Result := True;
end;

end.