UINT CopyCallback(
  [in, optional]  HWND hwnd,
                  UINT wFunc,
                  UINT wFlags,
  [in]            PCTSTR pszSrcFile,
                  DWORD dwSrcAttribs,
  [in, optional]  LPCTSTR pszDestFile,
                  DWORD dwDestAttribs
);

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;

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;

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.

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

// 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の登録解除

// 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

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

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

//-----------------------------------------------------------------------------
//  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;

//=============================================================================
//  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;

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

  %windir%\Sysnative\cmd.exe

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

  %windir%\SysWOW64\cmd.exe

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.

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.

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.

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.