Delphi Programming / Object Pascal
サイトのトップページへ リンクのページへ ロゴマーク
[掲載 2008年01月13日] [更新 2018年10月15日]　Delphi サンプルプログラム集
000_コマンドラインコンパイラの実行
動作確認等 Windows 7 U64(SP1) + Delphi XE(UP1) Pro
Windows 7 U64(SP1) + Delphi XE5(UP2) Pro VCL-32, VCL-64
000_CommandLineCompile.zip　[3,133 KB]　2018年10月15日版 (EXE 同梱)



  • 2018年10月15日 (これより前の履歴は省略)
  • インストールされている Delphi のバージョンを自動で検出するようにした



コマンドラインコンパイラの実行


このサンプルプログラムは，当サイトで提供しているサンプルプログラムの動作確認用に作成したものです．Delphiの IDE を起動しないでコンパイルが可能かを確認することができます．
以下の様な仕様となっています．
  • 起動すると，現在のシステムにインストールされている Delphi のバージョンを検出
  • 各 Delphi のバージョンのライブラリパスも自動検出してライブラリパスを設定
  • 指定したフォルダ内のサブフォルダ内も含めてプロジェクト全てをコンパイルする
  • フォルダまたはプロジェクトファイルのドラッグ・アンド・ドロップにも対応
  • リソースファイル (.res ファイル等) がないプロジェクトはコンパイルできない
  • インクルードファイルは，それが必要なファイルと同じフォルダにないと機能しない
  • Delphi XE2 以降では，ユニットスコープ名がないとコンパイル不可の場合がある

コンパイルができても，作成した EXE が正常に動作するとは限りません．プロジェクトを作成したバージョンによっては，他のバージョンではコンパイルできないこともあります．


[備考]
本ページのサンプルでは，コマンドラインコンパイラとして，dcc32.exe または dcc64.exe を使用しています．dcc32.exe も dcc64.exe も .dpr, dproj どちらのプロジェクトファイルでもコンパイルできますが，本ページのサンプルでは .dpr だけを使用する仕様になっています．
MSBuild を使用してコンパイルする場合は，プロジェクトファイルとして .dproj を使用します．.dpr ではコンパイルできません．





01_フォルダ内の全てのプロジェクトをコンパイル


[フォルダ指定] ボタンをクリックして，フォルダを指定すると，そのフォルダ内のプロジェクト全てをコンパイルします．手順は以下の図の説明を参考にしてください．プロジェクトファイルのドラッグ・アンド・ドロップにも対応しています

このプログラムを，Windows Vista 以降で実行する場合は，管理者権限 [管理者として実行] する必要があります．そこで，アプリケーションマニフェストを使用しています．EXE 起動時に，下図のよう管理者への昇格確認のダイアログが表示されます．



図1
管理者権限で実行

  • 図2
  • 設計時画面

  • 図3
  • 指定したフォルダ内 (サブフォルダ内も全て含む) を Delphi XE でコンパイル中
  • タブを切り替えると，別バージョンの Delphi でのコンパイルとなる
  • リソースファイルがないプロジェクトは，コンパイル不可

  • 図4
  • 必要であればライブラリパスを追加
  • Delphi の IDE で設定したパスも追加可能
  • プロジェクトフォルダの 1 つ上のフォルダは，実行時に自動で検索パスに追加される
  • この設定は本アプリのみで有効で，Delphi のバージョンごとに設定を保存
  • 実際にパスが存在するかのチェック機能はない

リスト1
指定フォルダ内の全プロジェクトをコンパイル
リソースファイルがないプロジェクトは，コンパイル不可		 
unit CommandLineCompileUnit;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, ComCtrls, StdCtrls, ExtCtrls, AppEvnts, Generics.Collections,
  Generics.Defaults;

type
  TDelphiVerInfo = record
    ProductVer  : Double;
    AppFullPath : string;
    RegKeyBase  : string;
    VersionStr  : string;
    Enable64bit : Boolean;
  end;

  TForm1 = class(TForm)
    TabControl1: TTabControl;
    Panel1: TPanel;
    btnFolder: TButton;
    btnCancel: TButton;
    CheckBox1: TCheckBox;
    CheckBox2: TCheckBox;
    btnEditLibPath: TButton;
    CheckBox3: TCheckBox;
    CheckBox4: TCheckBox;
    Memo1: TMemo;
    Panel3: TPanel;
    Label1: TLabel;
    ProgressBar1: TProgressBar;
    OpenDialog1: TOpenDialog;
    ApplicationEvents1: TApplicationEvents;
    btnClearConfig: TButton;
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure btnEditLibPathClick(Sender: TObject);
    procedure btnFolderClick(Sender: TObject);
    procedure btnCancelClick(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure TabControl1Change(Sender: TObject);
    procedure CheckBox1Click(Sender: TObject);
    procedure ApplicationEvents1Message(var Msg: tagMSG; var Handled: Boolean);
    procedure btnClearConfigClick(Sender: TObject);
  private
    { Private 宣言 }
    FCancelFlag : Boolean;
    procedure GetdprFilesListAll(APath: string; FileList:TStringList);
    function CreateCommandLineStr(dccPath: string; ProjName: string): string;
    procedure ControlsEnabled(WC: TWinControl; Flag : Boolean);
    function ComplieProject(dccPath: string; FileList: TStringList): Integer;
  public
    { Public 宣言 }
    FIniFileName : string;
    procedure SetDefaultLibPath(TabName, ConfigFileName: string; SL: TStringList);
  end;

  procedure GetDelphiVerList(AList: TList<TDelphiVerInfo>);
  function Is64bitWindows: Boolean;

var
  Form1: TForm1;

implementation

uses
  IniFiles,
  Registry,
  FileCtrl,
  Types,
  IOUtils,
  ShlObj,
  ShellAPI,
  StrUtils,
  EditLibraryPath,
  plCommandRedirect;

//ChangeWindowMessageFilter関数用の定数
const
  MSGFLT_ADD        = 1;
  MSGFLT_REMOVE     = 2;
  WM_COPYGLOBALDATA = $0049;

{$R *.dfm}

//=============================================================================
//  初期化処理
//=============================================================================
procedure TForm1.FormCreate(Sender: TObject);
var
  LFuncFilter : function (msg: Cardinal; dwFlag: DWORD): BOOL; stdcall;
  LDLLHandle  : THandle;
  LIniFile    : TIniFile;
  LFormLeft   : Integer;
  LDelphiList : TList<TDelphiVerInfo>;
  LDelphiInfo : TDelphiVerInfo;
  LIndex      : Integer;
  LAppKeyLib  : string;
  LdccexePath : string;
  LIniTabName : string;
  LTabName    : string;
begin
  //---------------------------------------------------------------------------
  //  ユーザーインターフェイス特権の分離 (UIPI)対策
  //  低い権限で実行したアプリ(エクスプローラ等)からのドラッグ&ドロップを受付
  //  Windows Vista以降用
  //  関数ChangeWindowMessageFilterは，Windows XP以前にはないのでGetProcAddress
  //  で確認する必要がある
  //---------------------------------------------------------------------------
  if CheckWin32Version(6, 0) then begin
    LDLLHandle := loadLibrary('user32.dll');
    try
      if LDLLHandle > 0 then begin
        @LFuncFilter := GetProcAddress(LDLLHandle, 'ChangeWindowMessageFilter');
        if @LFuncFilter <> nil then begin
          LFuncFilter(WM_DROPFILES,      MSGFLT_ADD);
          LFuncFilter(WM_COPYDATA,       MSGFLT_ADD);
          LFuncFilter(WM_COPYGLOBALDATA, MSGFLT_ADD);
        end;
      end;
    finally
      FreeLibrary(LDLLHandle);
    end;
  end;


  btnCancel.Enabled := False;

  Label1.Caption       := '';
  ProgressBar1.Visible := False;
  Memo1.ReadOnly       := True;
  Memo1.Lines.Clear;


  FIniFileName := ChangeFileExt(Application.ExeName, '.ini');
  LIniFile := TIniFile.Create(FIniFileName);
  try
    LFormLeft := 0;
    LTabName  := '';
    if FileExists(FIniFileName) then begin
      LIniTabName := LIniFile.ReadString ('Common', 'TabName',   '');
      LFormLeft   := LIniFile.ReadInteger('Common', 'FormLeft',   0);
      Self.Top    := LIniFile.ReadInteger('Common', 'FormTop',    Top);
      Self.Width  := LIniFile.ReadInteger('Common', 'FormWidth',  Width);
      Self.Height := LIniFile.ReadInteger('Common', 'FormHeight', Height);

      CheckBox1.Checked := LIniFile.ReadBool('Common', 'Checkbox1', False);
      CheckBox2.Checked := LIniFile.ReadBool('Common', 'Checkbox2', False);
      CheckBox3.Checked := LIniFile.ReadBool('Common', 'Checkbox3', True);
      CheckBox4.Checked := LIniFile.ReadBool('Common', 'Checkbox4', True);
    end;
  finally
    FreeAndNil(LIniFile);
  end;

  if LFormLeft = 0 then begin
    Self.Position := poMainFormCenter;
  end else begin
    Self.Position := poDesigned;
    Self.Left := LFormLeft;
  end;

  if TabControl1.Tabs.Count = 0 then begin
    //Delphiの各バージョンの情報を取得
    //取得した情報は内部で確保してもいいのだが参考のためにIniファイルに保存
    //この設定をIniファイルから読み込んで使用
    LDelphiList := TList<TDelphiVerInfo>.Create;
    GetDelphiVerList(LDelphiList);

    LIniFile := TIniFile.Create(FIniFileName);
    try
      TabControl1.TabHeight := 23;
      TabControl1.TabWidth  := 120;

      for LDelphiInfo in LDelphiList do begin
        LdccexePath := ExtractFilePath(LDelphiInfo.AppFullPath);
        LAppKeyLib  := LDelphiInfo.RegKeyBase + '\Library';

        if LDelphiInfo.Enable64bit then begin
          LTabName := LDelphiInfo.VersionStr + ' (32)';
          TabControl1.Tabs.Add(LTabName);
          LIniFile.WriteString(LTabName, 'dcc32exePath', LdccexePath + 'dcc32.exe');
          LIniFile.WriteString(LTabName, 'AppKeyLib', LAppKeyLib + '\Win32');
          LIniFile.WriteFloat(LTabName, 'ProductVer', LDelphiInfo.ProductVer);

          if Is64bitWindows then begin
            LTabName := LDelphiInfo.VersionStr + ' (64)';
            TabControl1.Tabs.Add(LTabName);
            LIniFile.WriteString(LTabName, 'dcc32exePath', LdccexePath + 'dcc64.exe');
            LIniFile.WriteString(LTabName, 'AppKeyLib', LAppKeyLib + '\Win64');
            LIniFile.WriteFloat(LTabName, 'ProductVer', LDelphiInfo.ProductVer);
          end;
        end else begin
          LTabName := LDelphiInfo.VersionStr;
          TabControl1.Tabs.Add(LTabName);
          LIniFile.WriteString(LTabName, 'dcc32exePath', LdccexePath + 'dcc32.exe');
          LIniFile.WriteString(LTabName, 'AppKeyLib', LAppKeyLib);
          LIniFile.WriteFloat(LTabName, 'ProductVer', LDelphiInfo.ProductVer);
        end;
      end;
    finally
      FreeAndNil(LIniFile);
      FreeAndNil(LDelphiList);
    end;
  end;

  if TabControl1.Tabs.Count = 0 then begin
    ControlsEnabled(Panel1, False);
  end else begin
    LIndex := TabControl1.Tabs.IndexOf(LIniTabName);
    if LIndex < 0 then LIndex := 0;
    TabControl1.TabIndex := LIndex;
    TabControl1Change(nil);

    //ドラッグアンドドロップを許可
    //usesにShellAPIが必要
    DragAcceptFiles(Memo1.Handle, True);
    DragAcceptFiles(Panel1.Handle, True);
  end;
end;

//=============================================================================
//  フォームを閉じる時は，フォームの位置とサイズをiniファイルに保存
//=============================================================================
procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
var
  LIniFile : TIniFile;
  LTabName : string;
  LStrList : TStringList;
  LIndex   : Integer;
begin
  if TabControl1.Tabs.Count = 0 then begin
    LTabName := '';
  end else begin
    LTabName := TabControl1.Tabs[TabControl1.TabIndex];
  end;

  LIniFile := TIniFile.Create(FIniFileName);
  LStrList := TStringList.Create;
  try
    //IniファイルのCommon以外のセクションを消去
    LIniFile.ReadSections(LStrList);
    for LIndex := LStrList.Count - 1 downto 0 do begin
      if LStrList[LIndex] = 'Common' then continue;
      LIniFile.EraseSection(LStrList[LIndex]);
    end;

    LIniFile.WriteString ('Common', 'TabName',    LTabName);
    LIniFile.WriteInteger('Common', 'FormTop',     Self.Top);
    LIniFile.WriteInteger('Common', 'FormLeft',    Self.Left);
    LIniFile.WriteInteger('Common', 'FormWidth',   Self.Width);
    LIniFile.WriteInteger('Common', 'FormHeight',  Self.Height);
  finally
    FreeAndNil(LIniFile);
    FreeAndNil(LStrList);
  end;
end;

//=============================================================================
//  [パス編集]
//  コンパイルに使用するライブラリのパスの編集
//  ここで設定しない場合は，$(DELPHI)Libまたは$(BDS)のdcc32.cfgの設定のみを使
//  用することになる
//=============================================================================
procedure TForm1.btnEditLibPathClick(Sender: TObject);
begin
  Form2 := TForm2.Create(Self);
  try
    Form2.ShowModal;
    Update;
  finally
    FreeAndNil(Form2);
  end;
end;

//=============================================================================
//  [フォルダ指定]
//  フォルダを選択してコンパイル開始
//  コマンドラインの実行には，サンプルプログラム集の[552_コマンドラインのリダイ
//  レクト]で作成したユニットCommandRedirectを使用
//
//  選択したフォルダ内のdprファイルを検索してコンパイルする
//  コンパイルのオプションはCreateCommandLineStrメソッドで作成
//  リソース(.res)がないプロジェクトはコンパイルできない
//=============================================================================
procedure TForm1.btnFolderClick(Sender: TObject);
var
  LFileDlg    : TFileOpenDialog;
  LIniFile    : TIniFile;
  LTabName    : string;
  LBasePath   : string;
  LdccexePath : string;
  LFileList   : TStringList;
begin
  LIniFile := TIniFile.Create(FIniFileName);
  LTabName := TabControl1.Tabs[TabControl1.TabIndex];

  //前回終了時のフォルダを初期フォルダに
  LBasePath   := '';
  LdccexePath := '';

  try
    if FileExists(FIniFileName) then begin
      LBasePath := LIniFile.ReadString('Common', 'BasePath', '');
      if LIniFile.SectionExists(LTabName) then begin
        LdccexePath := LIniFile.ReadString(LTabName, 'dcc32exePath', '');
      end;
    end;

    if LBasePath = '' then begin
      LBasePath := ExtractFileDir(Application.ExeName);
    end;

    if not FileExists(LdccexePath) then begin
      ShowMessage('コマンドラインコンパイラが見つかりません．');
    end else begin
      //Windows Vista以上の場合
      if CheckWin32Version(6, 0) then begin
        LFileDlg := TFileOpenDialog.Create(Self);
        try
          LFileDlg.Options := [fdoPickFolders, fdoForceFileSystem];
          LFileDlg.DefaultFolder := LBasePath;
          LFileDlg.FileName      := LBasePath;
          if LFileDlg.Execute then begin
            Update;
            LBasePath := LFileDlg.FileName;

            LFileList := TStringList.Create;
            try
              GetdprFilesListAll(IncludeTrailingPathDelimiter(LBasePath), LFileList);
              ComplieProject(LdccexePath, LFileList)
            finally
              FreeAndNil(LFileList);
            end;
          end;
        finally
          FreeAndNil(LFileDlg);
        end;
      end else begin
        if FileCtrl.SelectDirectory('対象フォルダ指定',  '', LBasePath) then begin
          LIniFile.WriteString('Common', 'BasePath', LBasePath);

          LFileList := TStringList.Create;
          try
            GetdprFilesListAll(IncludeTrailingPathDelimiter(LBasePath), LFileList);
            ComplieProject(LdccexePath, LFileList)
          finally
            FreeAndNil(LFileList);
          end;
        end;
      end;
    end;
    LIniFile.WriteString('Common', 'BasePath', LBasePath);
  finally
    FreeAndNil(LIniFile);
  end;
end;

//=============================================================================
//  各Delphiのバージョンのライブラリハスを格納したファイルを削除
//=============================================================================
procedure TForm1.btnClearConfigClick(Sender: TObject);
var
  LDir      : string;
  LFileList : TStringDynArray;
  LCFGFile  : string;
  LTabName  : string;
  LIndex    : Integer;
begin
  LTabName  := TabControl1.Tabs[TabControl1.TabIndex];
  LDir      := ExtractFileDir(Application.ExeName);
  LFileList := TDirectory.GetFiles(LDir, '*.CFG', TSearchOption.soTopDirectoryOnly);
  for LIndex := 0 to Length(LFileList) - 1 do begin
    LCFGFile := LFileList[LIndex];
    if ContainsText(LCFGFile, LTabName) then Continue;
    if FileExists(LCFGFile) then begin
      DeleteFile(LCFGFile);
    end;
  end;
end;

//=============================================================================
//  エクスプローラからのファイルのドラッグ・ドロップ処理
//=============================================================================
procedure TForm1.ApplicationEvents1Message(var Msg: tagMSG;
  var Handled: Boolean);
var
  LCount      : Integer;
  LBuffer     : array [0..MAX_PATH - 1] of Char;
  LPath       : string;
  LIniFile    : TIniFile;
  LTabName    : string;
  LdccexePath : string;
  LFileList   : TStringList;
  LCmdExeName : WideString;
  LCmdLine    : TplCommandRedirect;
  LFileCount  : Integer;
  LCheckFlag  : Boolean;
  LIndex      : Integer;
begin
  LCmdExeName := '';

  if Msg.message =WM_DROPFILES then begin
    LCheckFlag := CheckBox1.Checked;

    if (FindDragTarget(Msg.pt, False) = Memo1) or
       (FindDragTarget(Msg.pt, False) = Panel1) then begin

      LFileList := TStringList.Create;
      LFileList.Sorted := True;
      Memo1.Clear;
      Memo1.Update;
      try
        try
          LCount       := DragQueryFile(Msg.wParam, High(DWORD), nil, 0);
          LFileCount := 0;
          for LIndex := 0 to LCount - 1 do begin
            DragQueryFile(Msg.WParam, LIndex, LBuffer, MAX_PATH);
            LPath := LBuffer;
            if UpperCase(ExtractFileExt(LPath)) = '.DPR' then begin
              //dprのドラッグアンドドロップの時はEXEがあってもコンパイルする
              CheckBox1.Checked := False;
              LFileList.Add(LPath);
            end else
            if UpperCase(ExtractFileExt(LPath)) = '.EXE' then begin
              //CreataeProcessのStartupInfoのdwFlagsにSTARTF_USESHOWWINDOWを指定
              //しているのでcmd.exeが必要
              LCmdExeName := 'cmd.exe /c ' + LPath;
              inc(LFileCount);
            end else
            if SysUtils.DirectoryExists(LPath) then begin
              GetdprFilesListAll(IncludeTrailingPathDelimiter(LPath), LFileList);
            end;
          end;
        finally
          //ドロップが完了したことを伝える
          DragFinish(msg.WParam);
        end;

        if LCmdExeName <> '' then begin
          if LFileCount > 1 then begin
            ShowMessage('EXEファイルは1つしか実行できません．');
          end else begin
            Screen.Cursor := crHourGlass;
            LCmdLine      := TplCommandRedirect.Create;
            try
              Memo1.Text := LCmdLine.GrabStdOutText(LCmdExeName);
            finally
              LCmdLine.Free;
              Screen.Cursor := crDefault;
            end;
          end;
        end else begin;
          LIniFile := TIniFile.Create(FIniFileName);
          LTabName := TabControl1.Tabs[TabControl1.TabIndex];

          LdccexePath := '';
          try
            if FileExists(FIniFileName) then begin
              if LIniFile.SectionExists(LTabName) then begin
                LdccexePath := LIniFile.ReadString(LTabName,'dcc32exePath','');
              end;
            end;

            if not FileExists(LdccexePath) then begin
              ShowMessage('コマンドラインコンパイラが見つかりません．');
            end else begin
              ComplieProject(LdccexePath, LFileList)
            end;
          finally
            FreeAndNil(LIniFile);
          end;
        end;
      finally
        FreeAndNil(LFileList);
      end;
    end;
    CheckBox1.Checked := LCheckFlag;
  end;
end;

//-----------------------------------------------------------------------------
//  APath内のdprファイルを，サブフォルダ内も含めて再帰的に検索
//  フルパスで取得し引数のFileListに格納
//  CheckBox1をチェックしている場合はexe作成済みのプロジェクトを除外
//-----------------------------------------------------------------------------
procedure TForm1.GetdprFilesListAll(APath: string; FileList: TStringList);
var
  LFileList : TStringDynArray;
  LexeName  : string;
  LLoopCnt  : Integer;
begin
  LFileList := TDirectory.GetFiles(APath, '*.dpr', TSearchOption.soAllDirectories);
  for LLoopCnt := 0 to Length(LFileList) - 1 do begin
    if CheckBox1.Checked then begin
      LexeName := ChangeFileExt(LFileList[LLoopCnt], '.exe');
      if not FileExists(LexeName) then begin
        FileList.Add(LFileList[LLoopCnt]);
      end;
    end else begin
      FileList.Add(LFileList[LLoopCnt]);
    end;
  end;
end;

//-----------------------------------------------------------------------------
//  コンパイル実行のメソッド
//
//  パイプを使用してコンパイル実行メッセージを読み出すようにしている
//
//  [引数]
//  dccPath    コマンドコンパイラのフルパス
//  FlieList   コンパイル対象のdprファイルのリスト
//-----------------------------------------------------------------------------
function TForm1.ComplieProject(dccPath: string; FileList: TStringList): Integer;
var
  LProjName  : string;
  LOptionStr : string;
  LCmdLine   : TplCommandRedirect;
  LCmdStr    : string;
  LLoopCnt   : Integer;
  LStrList   : TStringList;
begin
  Screen.Cursor := crHourGlass;
  Result := 0;
  ControlsEnabled(Panel1, False);
  btnCancel.Enabled := True;

  Memo1.Clear;
  Update;
  FCancelFlag            := False;
  Label1.Caption        := IntToStr(0) + '/' + IntToStr(FileList.Count);
  ProgressBar1.Position := 0;
  ProgressBar1.Visible  := True;

  LCmdLine := TplCommandRedirect.Create;
  LStrList := TStringList.Create;

  try
    ProgressBar1.Min := 0;
    ProgressBar1.Max := FileList.Count;

    for LLoopCnt := 0 to FileList.Count - 1 do begin
      LOptionStr := CreateCommandLineStr(dccPath, FileList[LLoopCnt]);
      LProjName  := AnsiQuotedStr(FileList[LLoopCnt], '"');

      //-Uオプションで対象プロジェクトのフォルダを指定しているがうまく働か
      //ないプロジェクトがあるので，ここでカレントディレクトリを変更してみた
      //現在のところOKのようである
      SetCurrentDir(ExtractFileDir(FileList[LLoopCnt]));

      //エラーが発生しないとファイル名を表示しないので追加
      Memo1.Lines.Add(FileList[LLoopCnt]);

      //プロジェクトをコマンドラインコンパイラでコンパイル
      LCmdStr := dccPath + ' ' + LProjName + '' + LOptionStr;
      LStrList.Text := LCmdLine.GrabStdOutText(LCmdStr);
      if Trim(LStrList.Text) = '' then LStrList.Text := 'コンパイルに失敗しました';
      Memo1.Lines.Add(LStrList.Text);
      Memo1.Lines.Add(sLineBreak);


      ProgressBar1.Position := LLoopCnt + 1;
      Label1.Caption := IntToStr(LLoopCnt + 1) + '/' + IntToStr(FileList.Count);
      ProgressBar1.Update;
      Label1.Update;

      Application.ProcessMessages;
      if FCancelFlag then break;
    end;
  finally
    FreeAndNil(LCmdLine);
    FreeAndNil(LStrList);
    //カレントディレクトリをこのフォルダに戻す
    SetCurrentDir(ExtractFileDir(Application.ExeName));

    ControlsEnabled(Panel1,True);
    btnCancel.Enabled := False;
  end;
  ProgressBar1.Visible := False;
  Screen.Cursor := crDefault;
end;

//-----------------------------------------------------------------------------
//  コンパイルオプションの文字列を作成する関数
//  コマンドコンパイラ(dcc32.exe)は以下の順番にコンパイルオプションの設定を読む
//  設定はオーバライドして使用される
//  このメソッドで作成しているのは(4)
//  引数のProjNameがプロジェクトのフルパス(dprファイル)
//  検索(ライブラリ)パスとして，コンパイル対象のファイルがある1つ上の階層のフォ
//  ルダも追加している
//
//  (1) $(DELPHI)Binまたは$(BDS)Binのdcc32.cfg
//  (2) カレントディレクトリのdcc32.cfg
//  (3) コンパイル対象プロジェクトのディレクトリのdcc32.cfg
//  (4) コマンドラインで指定したオプション文字列
//
//  コンパイルオプション(Pipeによる出力にも影響する)
//  -A  ユニットのエイリアス設定．
//  -B  再構築．DLLやリソースファイルの修正をプロジェクトのEXEに反映するにため
//      には再構築が必要．
//  -U  ライブラリパスの指定．複数の時は;(セミコロン)で区切る．
//      IDEの[ツール][環境オプション]の[ライブラリ]タブに相当するが，コマンドラ
//      インコンパイラの場合は，複数のユニットを使用する場合，そのプロジェクト
//      のフォルダも指定する必要がある．
//  -E  作成したEXEファイルの置き場所．これを指定しなくても.dprと同じフォルダに
//      EXEファイルができるが，このオプションを指定しないと，DLLがカレントディ
//      レクトリ(このComplieAllProjet)にできてしまう．
//  -R  リソースファイル検索パス．
//  -H  ヒントメッセージの表示(Pipeに出力する)．
//  -W  警告メッセージの出力(Pipeに出力する)
//  -Q  Quietモード．コンパイル中のファイル名と行番号の表示をしない．起動時の著
//      作権メッセージと終了時のコンパイル結果の情報だけを表示.エラーが生じた場
//      合も表示(ここで表示とはPipeに出力するという意味)．
//-----------------------------------------------------------------------------
function TForm1.CreateCommandLineStr(dccPath: string; ProjName: string): string;
var
  LTabName        : string;
  LConfilFileName : string;
  LIniFile        : TIniFile;
  LProductVer     : Double;
  LStrList        : TStringList;
  LStr            : string;
  LProjDir        : string;
  LLoopCnt        : Integer;
begin
  LProjDir := ExtractFileDir(ProjName);
  LStrList := TStringList.Create;

  LTabName        := TabControl1.Tabs[TabControl1.TabIndex];
  LConfilFileName := ExtractFilePath(Application.ExeName)
                  + 'LibPath' + LTabName + '.CFG';
  try
    LStrList.LoadFromFile(LConfilFileName);

    //ヒントと警告は対象ユニットで表示オプションがある時は無効
    //ChekBox2は再構築の指定
    if CheckBox2.Checked then LStr := LStr + ' -B';

    //ChekBox3はヒント表示の指定
    if CheckBox3.Checked then LStr := LStr + ' -H+' else LStr := LStr + ' -H-';

    //ChekBox4は警告表示の指定
    if CheckBox4.Checked then LStr := LStr + ' -W+' else LStr := LStr + ' -W-';

    LStr := LStr
         + ' -Q'
         + ' -E' + AnsiQuotedStr(LProjDir, '"')
         + ' -R' + AnsiQuotedStr(LProjDir, '"');

    //Delphi XE2以降の場合
    //ユニットスコープ名(Delphi XE2のプロジェクトオプションからコピーしたリスト)
    //これだけでは不足しているかも知れない
    LIniFile := TIniFile.Create(FIniFileName);
    try
      LProductVer := LIniFile.ReadFloat(LTabName, 'ProductVer', 0);
      if LProductVer >= 15.99 then begin
        LStr := LStr + ' -NS'
             + 'Winapi'
             + ';System.Win'
             + ';Data.Win'
             + ';Datasnap.Win'
             + ';Web.Win;'
             + ';Soap.Win'
             + ';Xml.Win'
             + ';Bde'
             + ';System'
             + ';Xml'
             + ';Data'
             + ';Datasnap'
             + ';Web'
             + ';Soap'
             + ';Vcl'
             + ';Vcl.Imaging'
             + ';Vcl.Touch'
             + ';Vcl.Samples'
             + ';Vcl.Shell';
      end;
    finally
      FreeAndNil(LIniFile);
    end;

    //ライブラリパスの追加
    LStr := LStr + ' -U';
    for LLoopCnt := 0 to LStrList.Count - 1 do begin
      if LLoopCnt = 0 then begin
        LStr := LStr + AnsiQuotedStr(LStrList[LLoopCnt], '"');
      end else begin
        LStr := LStr + ';' + AnsiQuotedStr(LStrList[LLoopCnt], '"');
      end;
    end;
    //対象プロジェクトとその1つ上の階層のフォルダを検索対象として追加
    Result := LStr
            + ';' + AnsiQuotedStr(LProjDir, '"')
            + ';' + AnsiQuotedStr(ExtractFileDir(LProjDir), '"');
  finally
    FreeAndNil(LStrList);
  end;
end;

//=============================================================================
//  [キャンセル]
//=============================================================================
procedure TForm1.btnCancelClick(Sender: TObject);
begin
  FCancelFlag := True;
end;

//-----------------------------------------------------------------------------
//  引数のWCで指定するコントロール上のコントロールのEnabledプロパティを設定
//  TPanelの上に載っているコントロールはTPanelをDisalbeにすれば操作不可になる
//  が視覚的効果がないので，ここで設定
//-----------------------------------------------------------------------------
procedure TForm1.ControlsEnabled(WC: TWinControl; Flag: Boolean);
var
  LControl : TControl;
  LIndex   : Integer;
begin
  if WC.ControlCount = 0 then exit;
  for LIndex := 0 to WC.ControlCount - 1 do begin
    LControl := WC.Controls[LIndex];
    LControl.Enabled := Flag;
    if LControl is TWinControl then ControlsEnabled(TWinControl(LControl),Flag);
  end;
end;

//=============================================================================
//  タブコントロールのタブを切り替えたら
//=============================================================================
procedure TForm1.TabControl1Change(Sender: TObject);
var
  LIniFile    : TIniFile;
  LConfigFile : string;
  LStrList    : TStringList;
  LTabName    : string;
begin
  LIniFile    := TIniFile.Create(FIniFileName);
  LTabName    := TabControl1.Tabs[TabControl1.TabIndex];
  LConfigFile := 'LibPath' + LTabName + '.CFG';

  try
    LIniFile.WriteString('Common', 'TabName', LTabName);
  finally
    FreeAndNil(LIniFile);
  end;

  //ライブラリパスの設定ファイルがなければ調査して保存
  //初めてタブを切り換えた場合のみ実行する
  if not FileExists(LConfigFile) then begin
    LStrList := TStringList.Create;
    try
      //ライブラリパスの検出
      SetDefaultLibPath(LTabName, LConfigFile, LStrList);
      LStrList.SaveToFile(LConfigFile);
    finally
      FreeAndNil(LStrList);
    end;
  end;
end;

//=============================================================================
//  コンパイルの条件設定用のチェックボックスの状態を変更したら
//  それをIniファイルに保存
//=============================================================================
procedure TForm1.CheckBox1Click(Sender: TObject);
var
  LIniFile : TIniFile;
begin
  LIniFile := TIniFile.Create(FIniFileName);
  try
    LIniFile.WriteBool('Common', 'Checkbox1', CheckBox1.Checked);
    LIniFile.WriteBool('Common', 'Checkbox2', CheckBox2.Checked);
    LIniFile.WriteBool('Common', 'Checkbox3', CheckBox3.Checked);
    LIniFile.WriteBool('Common', 'Checkbox4', CheckBox4.Checked);
  finally
    FreeAndNil(LIniFile);
  end;
end;

//-----------------------------------------------------------------------------
//  DelphiのIDEで設定してあるライブラリパスを追加
//  ライブラリパスの取得方法がわからないのでレジストリから取得
//  重複するパスの文字列は追加しない
//  ただし$(DELPHI)や$(BDS)等は別文字列として扱っている
//
//  例えばDelphi7の場合，$(DELPHI)とC:\Program Files\Borland\Delphi7\binは実際
//  には同じパスを意味しているが，ここでは重複してしまう
//-----------------------------------------------------------------------------
procedure TForm1.SetDefaultLibPath(TabName, ConfigFileName: string;
  SL: TStringList);
var
  LIniFile : TIniFile;
  LReg     : TRegistry;
  LAppKey  : string;
  LAppItem : string;
begin
  //IniファイルからKEY値を読み出す
  //ルートキーがHKEY_CURRENT_USERと仮定して，EXE起動時にKEY項目を取得すみ
  LIniFile := TIniFile.Create(FIniFileName);
  try
    LAppKey := LIniFile.ReadString(TabName, 'AppKeyLib', '');
  finally
    FreeAndNil(LIniFile);
  end;

  LReg := TRegistry.Create;
  try
    LReg.Access  := KEY_READ;
    LReg.RootKey := HKEY_CURRENT_USER;
    LAppItem     := 'Search Path';

    SL.Sorted        := True;
    SL.Duplicates    := dupIgnore;
    SL.CaseSensitive := False;

    if LReg.OpenKey(LAppKey, False) then begin
      try
        SL.Delimiter       := ';';
        SL.StrictDelimiter := True;
        SL.DelimitedText   := LReg.ReadString(LAppItem);
      finally
        LReg.CloseKey;
      end;
    end;
  finally
    FreeAndNil(LReg);
  end;
end;

//-----------------------------------------------------------------------------
//  インストール済みDelphiの各バージョンの情報をジェネリックスのリストに格納
//  リストに格納するのはDephiの各バージョンの情報を格納するレコード型
//-----------------------------------------------------------------------------
procedure GetDelphiVerList(AList: TList<TDelphiVerInfo>);

  procedure InitializeRecord(var AInfo: TDelphiVerInfo);
  begin
    AInfo.ProductVer  := 0.0;
    AInfo.AppFullPath := 'Empty';
    AInfo.RegKeyBase  := 'Empty';
    AInfo.VersionStr  := 'Empty';
    AInfo.Enable64bit := False;
  end;

const
  LArrayBDS : array [0..2] of string
              = ('\Borland\BDS', '\CodeGear\BDS', '\Embarcadero\BDS');
var
  LRegistry    : TRegistry;
  LKeyBDS      : string;
  LKeyEeachVer : string;
  LKeyNameList : TStringList;
  LKeyItemList : TStringList;
  LAppInfo     : TDelphiVerInfo;
  LTempValue   : string;
  LLoopCnt     : Integer;
  LLoopBDS     : Integer;
begin
  AList.Clear;

  LRegistry    := TRegistry.Create;
  LKeyNameList := TStringList.Create;
  LKeyItemList := TStringList.Create;

  try
    LRegistry.Access  := KEY_READ;
    LRegistry.RootKey := HKEY_LOCAL_MACHINE;

    //-------------------------------------------------------------------------
    // Delphi 2 - 7
    // Delphi 4 までは最初の項目がDelphi のバージョン文字列
    // Delphi 5 からは項目名の App がEXEのフルパス
    //-------------------------------------------------------------------------
    LKeyBDS := 'Software\Borland\Delphi';

    if LRegistry.OpenKey(LKeyBDS, False) then begin
      // 現在のキーの階層下のキー名の一覧を取得
      // このキーがDelphiの各バージョンごとのキー
      LRegistry.GetKeyNames(LKeyNameList);

      for LLoopCnt := 0 to LKeyNameList.Count - 1 do begin
        LKeyEeachVer := LKeyBDS + PathDelim + LKeyNameList[LLoopCnt];

        LRegistry.CloseKey;
        InitializeRecord(LAppInfo);

        if LRegistry.OpenKey(LKeyEeachVer, False) then begin
          LAppInfo.ProductVer := StrToFloat(LKeyNameList[LLoopCnt]);

          if LAppInfo.ProductVer < 5.0 then begin
            // 現在のDelphiのキー名の各項目名(名前:レジストリエントリ)一覧を取得
            LRegistry.GetValueNames(LKeyItemList);
            if LKeyItemList.Count < 1 then Continue;
            LAppInfo.AppFullPath  := LRegistry.ReadString(LKeyItemList[0]);
          end else begin
            if not LRegistry.ValueExists('App') then Continue;
            LAppInfo.AppFullPath := LRegistry.ReadString('App');
          end;

          // Delphi のバージョン文字列の作成
          // 小数点以下が 0 の時は整数部だけとする
          LTempValue := Trim(LKeyNameList[LLoopCnt]);
          if RightStr(LTempValue, 2) = '.0' then begin
            LTempValue := LeftStr(LTempValue, 1);
          end;

          LAppInfo.VersionStr := 'Delphi ' + LTempValue;
          LAppInfo.RegKeyBase := LKeyEeachVer;

          // ジェネリックスのリストにレコード型のデータを追加
          AList.Add(LAppInfo);
        end;
      end;
    end;
    LRegistry.CloseKey;


    //-------------------------------------------------------------------------
    // Delphi 2005 以降
    //-------------------------------------------------------------------------
    for LLoopBDS := 0 to Length(LArrayBDS) - 1 do begin
      LKeyBDS := 'Software' + LArrayBDS[LLoopBDS];

      if LRegistry.OpenKey(LKeyBDS, False) then begin
        // 現在のキーの階層下のキー名の一覧を取得
        // このキーがDelphiの各バージョンごとのキー
        LRegistry.GetKeyNames(LKeyNameList);

        for LLoopCnt := 0 to LKeyNameList.Count - 1 do begin
          LKeyEeachVer := LKeyBDS + PathDelim + LKeyNameList[LLoopCnt];

          LRegistry.CloseKey;
          InitializeRecord(LAppInfo);

          if LRegistry.OpenKey(LKeyEeachVer, False) then begin
            if not LRegistry.ValueExists('App') then Continue;
            LAppInfo.AppFullPath := LRegistry.ReadString('App');

            if LRegistry.ValueExists('ProductVersion') then begin
              LAppInfo.ProductVer := StrToFloat(LRegistry.ReadString('ProductVersion'));
            end;

            LRegistry.CloseKey;
            // Delphi XE,Delphi XE5,..等の文字列を取得
            if LRegistry.KeyExists(LKeyEeachVer + '\Personalities') then begin
              if LRegistry.OpenKey(LKeyEeachVer + '\Personalities', False) then begin
                if LRegistry.ValueExists('Delphi.Win32') then begin
                  LAppInfo.VersionStr := LRegistry.ReadString('Delphi.Win32');
                end;
              end;
            end;

            LAppInfo.RegKeyBase := LKeyEeachVer;

            // 64 ビットの開発が可能かを調査
            if ContainsText(LKeyBDS, 'Embarcadero\BDS') then begin
              LRegistry.CloseKey;
              if LRegistry.KeyExists(LKeyEeachVer + '\Library\Win64') then begin
                // 64ビット用のWindowsアプリが開発可能な場合はTrue
                LAppInfo.Enable64bit := True;
              end else begin
                LAppInfo.Enable64bit := False;
              end;
            end;

            AList.Add(LAppInfo);
          end;
        end;
      end;
      LRegistry.CloseKey;
    end;

    //---------------------------------------------------------
    //  プロダクトバージョンの値でリストをソート
    //  TComparer関係の使用にはusesにGenerics.Defaultsが必要
    //---------------------------------------------------------
    AList.Sort(TComparer<TDelphiVerInfo>.Construct(
      function(const Left, Right: TDelphiVerInfo): Integer
      begin
        Result := Trunc((Left.ProductVer - Right.ProductVer) * 10);
      end)
    );
  finally
    FreeAndNil(LRegistry);
    FreeAndNil(LKeyNameList);
    FreeAndNil(LKeyItemList);
  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
    //Windows XPの64ビット版か
    Result := CheckWin32Version(5, 2);
  end;
end;

end.



リスト2
ライブラリパスの編集用コード 
unit EditLibraryPath;

interface

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

type
  TForm2 = class(TForm)
    Panel1: TPanel;
    btnAdd: TButton;
    btnDelete: TButton;
    Panel2: TPanel;
    btnAddDelphiPath: TButton;
    ListView1: TListView;
    ApplicationEvents1: TApplicationEvents;
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure btnAddClick(Sender: TObject);
    procedure btnDeleteClick(Sender: TObject);
    procedure btnAddDelphiPathClick(Sender: TObject);
    procedure FormResize(Sender: TObject);
    procedure ListView1SelectItem(Sender: TObject; Item: TListItem;
      Selected: Boolean);
    procedure ApplicationEvents1Message(var Msg: tagMSG; var Handled: Boolean);
    procedure FormCreate(Sender: TObject);
  private
    { Private 宣言 }
    FIniFilename : string;
    FConfigFile  : string;
    FTabName     : string;
    procedure AddOriginLibPath(APath: string);
  public
    { Public 宣言 }
  end;

var
  Form2: TForm2;

implementation

uses 
  FileCtrl,
  IniFiles,
  ShellAPI,
  CommandLineCompileUnit;

{$R *.dfm}

//=============================================================================
//  フォーム生成時の処理
//  iniファイルとライブラリバスを保存しているファイルから読み出して表示
//=============================================================================
procedure TForm2.FormCreate(Sender: TObject);
var
  LIniFile  : TIniFile;
  LFormLeft : Integer;
  LStrList  : TStringList;
  LLoopCnt  : Integer;
begin
  btnDelete.Enabled := False;

  FIniFilename := Form1.FIniFileName;
  FTabName     := Form1.TabControl1.Tabs[Form1.TabControl1.TabIndex];
  FConfigFile  := 'LibPath' + FTabName + '.CFG';

  Self.Caption := Self.Caption + ' ' + FTabName;
  LFormLeft   := 0;

  LIniFile := TIniFile.Create(FIniFileName);
  try
    if FileExists(FIniFileName) then begin
      LFormLeft   := LIniFile.ReadInteger('Common', 'EditFormLeft',   0);
      Self.Top    := LIniFile.ReadInteger('Common', 'EditFormTop',    Top);
      Self.Width  := LIniFile.ReadInteger('Common', 'EditFormWidth',  Width);
      Self.Height := LIniFile.ReadInteger('Common', 'EditFormHeight', Height);
    end;
  finally
    FreeAndNil(LIniFile);
  end;

  if LFormLeft = 0 then begin
    Self.Position := poMainFormCenter;
  end else begin
    Self.Position := poDesigned;
    Self.Left := LFormLeft;
  end;

  ListView1.Items.Clear;
  LStrList := TStringList.Create;
  LStrList.Sorted := True;
  LStrList.Duplicates := dupIgnore;
  try
    if FileExists(FConfigFile) then begin
      LStrList.LoadFromFile(FConfigFile);
      for LLoopCnt := 0 to LStrList.Count - 1 do begin
        if Trim(LStrList[LLoopCnt]) <> '' then begin
          ListView1.Items.Add.Caption := Trim(LStrList[LLoopCnt]);
        end;
      end;
    end else begin
      //Delphiパス取込
      btnAddDelphiPathClick(nil);
    end;
  finally
    FreeAndNil(LStrList);
  end;

  //ドラッグアンドドロップを許可
  //usesにShellAPIが必要
  DragAcceptFiles(ListView1.Handle, True);
end;

//=============================================================================
//  フォームを閉じる時は現在の設定値を保存
//  保存するのは，ライブラリパス名とこのフォームの表示位置とサイズ
//=============================================================================
procedure TForm2.FormClose(Sender: TObject; var Action: TCloseAction);
var
  LStrList : TStringList;
  LIniFile : TIniFile;
  LStr     : string;
  LIndex   : Integer;
begin
  LStrList := TStringList.Create;
  try
    for LIndex := 0 to ListView1.Items.Count - 1 do begin
      LStr := Trim(ListView1.Items[LIndex].Caption);
      if LStr <> '' then LStrList.Add(LStr);
    end;
    LStrList.SaveToFile(FConfigFile);
  finally
    FreeAndNil(LStrList);
  end;

  LIniFile := TIniFile.Create(FIniFileName);
  try
    LIniFile.WriteInteger('Common', 'EditFormTop',    Self.Top);
    LIniFile.WriteInteger('Common', 'EditFormLeft',   Self.Left);
    LIniFile.WriteInteger('Common', 'EditFormWidth',  Self.Width);
    LIniFile.WriteInteger('Common', 'EditFormHeight', Self.Height);
  finally
    FreeAndNil(LIniFile);
  end;
end;

//=============================================================================
//  フォームをリサイズしたらListViewの表示幅も変更
//=============================================================================
procedure TForm2.FormResize(Sender: TObject);
begin
  ListView1.Column[0].Width := ListView1.ClientWidth - GetSystemMetrics(SM_CXHSCROLL);
end;

//=============================================================================
//  [追加]
//  フォルダ選択ダイアログを表示して選択
//  初期フォルダは，Iniファイルに保存してある値を使用
//  それがなければこのプログラムがあるフォルダ
//  フォルダを選択したらそのフォルダ名をIniファイルに記録しておく
//=============================================================================
procedure TForm2.btnAddClick(Sender: TObject);
var
  LIniFile  : TIniFile;
  LBasePath : string;
begin
  LIniFile := TIniFile.Create(FIniFileName);

  try
    if FileExists(FIniFileName)then begin
      LBasePath := LIniFile.ReadString('Common', 'EditBasePath', '');
    end else begin
      LBasePath := ExtractFileDir(Application.ExeName);
    end;

    if SelectDirectory('ライブラリパス追加', '', LBasePath) then begin
      AddOriginLibPath(ExcludeTrailingPathDelimiter(LBasePath));
      LIniFile.WriteString('Common', 'EditBasePath', LBasePath);
    end;
  finally
    FreeAndNil(LIniFile);
  end;
  btnDelete.Enabled := False;
end;

//=============================================================================
//  [削除]
//  現在選択中のパスの設定を削除
//=============================================================================
procedure TForm2.btnDeleteClick(Sender: TObject);
begin
  ListView1.DeleteSelected;
end;

//=============================================================================
//  [Delphiパス取込]
//  DelphiのIDEで設定してあるライブラリパスを追加
//=============================================================================
procedure TForm2.btnAddDelphiPathClick(Sender: TObject);
var
  LStrList    : TStringList;
  LStrListAdd : TStringList;
  LStr        : string;
  LIndex      : Integer;
begin
  ListView1.Items.BeginUpdate;
  ListView1.Items.Clear;

  LStrList    := TStringList.Create;
  LStrListAdd := TStringList.Create;
  LStrList.Sorted     := True;
  LStrList.Duplicates := dupIgnore;

  for LIndex := 0 to ListView1.Items.Count -1 do begin
    LStr := Trim(ListView1.Items[LIndex].Caption);
    if LStr <> ''  then LStrList.Add(LStr);
  end;
  try
    Form1.SetDefaultLibPath(FTabName, FConfigFile, LStrListAdd);
    for LIndex := 0 to LStrListAdd.Count - 1 do begin
      LStr := Trim(LStrListAdd[LIndex]);
      if LStr <> '' then LStrList.Add(LStrListAdd[LIndex]);
    end;
    for LIndex := 0 to LStrList.Count - 1 do begin
      ListView1.Items.Add.Caption := LStrList[LIndex];
    end;
  finally
    FreeAndNil(LStrList);
    FreeAndNil(LStrListAdd);
  end;

  ListView1.Items.EndUpdate;
  btnDelete.Enabled := False;
end;

//=============================================================================
//  リストビューをクリックしたら，[削除]ボタンのEnabledを設定
//=============================================================================
procedure TForm2.ListView1SelectItem(Sender: TObject; Item: TListItem;
  Selected: Boolean);
begin
  btnDelete.Enabled := ListView1.SelCount > 0;
end;

//=============================================================================
//  エクスプローラからのファイルのドラッグ・ドロップ処理
//  ただし1つだけの場合のみ有効
//=============================================================================
procedure TForm2.ApplicationEvents1Message(var Msg: tagMSG;
  var Handled: Boolean);
var
  LCount     : Integer;
  LBuffer    : array [0..MAX_PATH] of Char;
  LDragPath  : string;
begin
  if Msg.message = WM_DROPFILES then begin
    if (FindDragTarget(Msg.pt, False) = ListView1) then begin
      LCount := DragQueryFile(Msg.wParam, High(DWORD), nil, 0);
      try
        if LCount = 1 then begin
          LDragPath := '';
          DragQueryFile(Msg.WParam, 0, LBuffer, MAX_PATH);
          LDragPath := LBuffer;
          AddOriginLibPath(LDragPath);
        end;
      finally
        //ドロップが完了したことを伝える
        DragFinish(msg.WParam);
      end;
    end;
  end;
end;

//-----------------------------------------------------------------------------
//  ライブラリパスに,引数のAPathを追加
//  重複しないための処理用関数
//-----------------------------------------------------------------------------
procedure TForm2.AddOriginLibPath(APath: string);
var
  LStrList : TStringList;
  LStr     : string;
  LIndex   : Integer;
begin
  //重複を避けるためにパスのリストを一度TStringListに 退避
  LStrList := TStringList.Create;
  LStrList.Sorted     := True;
  LStrList.Duplicates := dupIgnore;
  for LIndex := 0 to ListView1.Items.Count -1 do begin
    LStr := Trim(ListView1.Items[LIndex].Caption);
    if LStr <> ''  then LStrList.Add(LStr);
  end;

  //TStringListに退避したのでTListViewはクリア
  ListView1.Items.BeginUpdate;
  ListView1.Items.Clear;

  try
    if DirectoryExists(APath) then begin
      LStrList.Add(APath);
    end;

    //作成したパスリストをTListViewに表示
    for LIndex := 0 to LStrList.Count - 1 do begin
      ListView1.Items.Add.Caption := LStrList[LIndex];
    end;
  finally
    FreeAndNil(LStrList);
  end;

  ListView1.Items.EndUpdate;
  btnDelete.Enabled := False;
end;

end.



02_コンポーネントをインストールしないで動作確認


コマンドラインコンパイラでコンパイルすると，コンパイル対象のプロジェクトで使用しているコンポーネントをインストールしなくてもコンパイルできます．

コンポーネントのファイルは，パスの通ったフォルダに必要ですが，これは [パスの編集] で追加しておきます．添付のテスト用のプロジェクトでは 1 つ上の階層のフォルダにあります．この場合はパスを通す必要はありません．プロジェクトのフォルトの 1 つ上のフォルダも，実行時に自動でパスを通すようにしています．
ネット上で配布されているコンポーネント類のデモ，サンプルのプログラムには，リソースファイルがないものがあります．そのようなプロジェクトはコンパイルできません．


添付のテスト用プロジェクトは，[140_オブジェクトリスト ( クラス型 ) の保存 - TLabel] で使用している，画像表示機能付き縦横両用ラベルコンポーネントをフォームに配置しています．


  • 図5
  • プロジェクトファイル (dpr) のドラッグ・アンド・ドロップでコンパイル開始

図6
添付のテスト用プロジェクト
図7
コンパイルした結果
  • CompoTest.exe が出来ている
図8
EXE を実行

リスト3
テスト用のプロジェクトのフォームのユニット
TplVertLabel というビジュアルコンポーネントを3つフォームに配置している
Delphi XE2 でもコンパイルできるように，uses にユニットスコープ名を付けている 
unit CompoTestUnit;

interface

uses
  {$IF CompilerVersion > 22.99}
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, 
  System.Classes, Vcl.Graphics, Vcl.Controls, Vcl.Forms, Vcl.Dialogs, 
  Vcl.StdCtrls, plVertLabel;
  {$ELSE}
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, plVertLabel;
  {$IFEND}

type
  TForm1 = class(TForm)
    plVertLabel1: TplVertLabel;
    plVertLabel2: TplVertLabel;
    plVertLabel3: TplVertLabel;
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

end.



03_uses 部にユニットスコープ名を追加 ( Delphi XE2 以上用 )


uses 部のユニット名に，ユニットスコープ名を付けるプログラムを作成してみました．
Delphi XE2 よりも前のバージョンのコードを変換するのに利用できます．Embarcadero のサイトのデータを使用しますので．以下の手順で操作してください．

まず，Delphi のオンラインヘルプの [ユニット名とユニット スコープ名のアルファベット順一覧] のページを表示します

  • (1) そのページのリファレンス一覧をコピーします (=のある行を全て)
  • (2) 添付の UnitScopeList.txt を開きます．このファイルの中身は空です
  • (3) この UnitScopeList.txt にコピーしたテキストを貼り付けて，保存します
  • (4) AddUnitScopeUses.exe を起動します
  • (5) 拡張子が .pas または .dpr のファイルを，エクスプローラからドラッグ・ドロップします
  • (6) 変換結果が表示されます．これで OK なら [保存] ボタンで保存します (上書き保存です)

プロジェクトのソース (.dpr) は，Forms という部分だけにユニットスコープ名を付加します．逆にユニットスコープ名付きだけの uses 部の場合は，ユニットスコープ名なしのユニット名を，コンパイラのバージョン分岐を挿入して追加します．
なお，このプログラムのソースコードは添付していません．整備中です．

このプログラムは，特に管理者権限 [管理者として実行] する必要はありません．



  • 図9
  • ユニット名にユニットスコープ名を付加するプログラム
  • [保存] ボタンで上書き保存

リスト4
上の図の，元のコード 
unit Unit1;

interface

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

type
  TForm1 = class(TForm)
  private
    { Private 宣言 }
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

end.



04_ドラッグ・アンド・ドロップ機能の実装 ( Vista 以降の UIPI 対応 )


エクスプローラ等からのドラッグ・アンド・ドロップは，WM_DROPFILES メッセージを受信した後，関数 DragQueryFile で処理が可能です．
しかし，Windows Vista 以降では，ユーザーインタフェイス特権の分離 (UIPI) の機能のため，エクスプローラからのファイル名のドラッグ・アンド・ドロップができないことがあります．

コマンドラインコンパイラは，管理者権限で実行しないとコンパイルできません．一方，エクスプローラは通常，少し低い権限での起動となっています．高い権限で起動しているアプリケーションは，自分より低い権限で起動しているアプリケーションからのメッセージの受信に制限があります．
つまり，下からの要求には応じないというわけです．

逆の場合は可能です．つまり，同レベルと上からの指示は受け取ることになっています．
これが「ユーザインターフェイス特権の分離 (UIPI)」機能によって発生する現象の一部です．
したがって，Delphi の IDE から実行したプログラムは，エクスプローラからのドラッグ・アンド・ドロップができない場合があります．作成した EXE を一般ユーザで起動した場合は可能です．

そこで，ChangeWindowMessageFilter という関数で，ドラッグ・アンド・ドロップに関係するメッセージの受信を許可するために，以下のようなコードを追加しました．
ドラッグ・アンド・ドロップのメッセージは，WM_DROPFILES メッセージですが，実際には，関係する他のメッセージも同時に許可する必要があります．これは他の Windows のメッセージでも同じです．

ChangeWindowMessageFilter 関数は，Windows XP 以前にはありません．GetProcAddress 関数で，該当する DLL 内にこの関数があるかを確認してから処理しています．そうしないと，Windows XP でコンパイルできないコードとなってしまいます．これを，dll の動的リンクと言っています．



[備考 1]
ChangeWindowMessageFilter 関数，MSGFLT_ADD, MSGFLT_REMOVE, WM_COPYGLOBALDATA も Delphi XE5 には実装されています．関数と定数値の定義文を書く必要はありません．

[備考 2]
UIPI は，メッセージの送受信に関する機能です．影響を受けるのは，ドラッグ・ドロップ関係だけではありません．例えば，管理者権限で実行しているアプリの表示位置を SetWindowPos 関数を使用して変更しようとしても，一般ユーザで起動したアプリからは変更できません．



リスト5
Windows Vista 以降でファイル名のドラッグ・アンド・ドロップを実現するめに追加したコード
ChangeWindowMessageFilter 関数で，メッセージの受信を許可する		 
//ChangeWindowMessageFilter関数用の定数
const
  MSGFLT_ADD        = 1;
  MSGFLT_REMOVE     = 2;
  WM_COPYGLOBALDATA = $0049;

{$R *.dfm}

procedure TForm1.FormCreate(Sender: TObject);
var
  LFuncFilter : function (msg: Cardinal; dwFlag: DWORD): BOOL; stdcall;
  LDLLHandle  : THandle;
begin
  if CheckWin32Version(6, 0) then begin
    LDLLHandle := loadLibrary('user32.dll');
    try
      if LDLLHandle > 0 then begin
        @LFuncFilter := GetProcAddress(LDLLHandle, 'ChangeWindowMessageFilter');
        if @LFuncFilter <> nil then begin
          LFuncFilter(WM_DROPFILES,      MSGFLT_ADD);
          LFuncFilter(WM_COPYDATA,       MSGFLT_ADD);
          LFuncFilter(WM_COPYGLOBALDATA, MSGFLT_ADD);
        end;
      end;
    finally
      FreeLibrary(LDLLHandle);
    end;
  end;


アプリケーション間のメッセージ通信の問題に対応する別の方法があります．そのためには，
  • アプリケーション マニフェストに通信を許可するコードがある
  • デジタル署名 ( コードサイニング証明書 ) を取得している
  • アプリケーションの実行ファイルが %ProgramFiles% フォルダにある

という条件が必要です．詳しい内容は，参考リンクのマイクロソフトの記事にあります．
メッセージの受信許可の設定には注意が必要です．間違って他のユーザのファイルを操作するような設定をしてしまう恐れもあります．



[備考 3]
エクスプローラの操作権限は，その環境にもよります．例えば，ネットワーク上のドライブのフォルダを開く際，管理者権限が必要であれば，管理者権限で起動することになります．
この場合も，どの操作が可能であるかは，セキュリティの設定も関係してきます．
この仕様は，Windows XP の時代にはすでに実装されていました．Windows Vista では，UAC の実装に伴って，確実に機能するようになったとも言えます．




05_Window 7 64 ビット版のレジストリの構成


このコマンドラインコンパイラの実行では，レジストリからコンパイラの情報を取得しています．
もし，64 ビットの EXE を作製した場合，レジストリからの読み出しと，コマンドコンパイラの実行に注意が必要です．そこで，レジストリへのアクセスの簡単なテストをしてみました．
このテストは，64 ビット版の Windows のみで意味のある内容となっています．

64 ビット版の Windows 7 には，32 ビットバージョンのレジストリエディタと 64 ビットバージョンのレジストリエディタがあります．
64 ビットのアプリケーション関係はもちろん 64 ビットバージョンのレジストリに書き込まれます．32 ビットのアプリケーションの [HKEY_LOCAL_MACHINE] [SOFTWARE] 関係の情報は，32 ビットバージョンのレジストリに書き込まれますが，64 ビットバージョンのレジストリにも書き込まれます．そこは，下図のように， 


[HKEY_LOCAL_MACHINE] [SOFTWARE] [Wow6432Node]

という場所です．

通常はリダイレクト機能が働くので，特にこのキー項目を意識する必要はありません．
問題となるのは，32 ビットのアプリから 64 ビットバージョンのレジストリを操作するとか，64 ビットのアプリから 32 ビットバージョンのレジストリを操作する時です．

この後のサンプルは，この動作を確認するためのテストプログラムです．


64 ビット版の Windows の 32 ビット版レジストリエディタは，次のコマンドで起動できます．
[ファイル名を指定して実行] のダイアログで，以下をコピペしても起動できます．
32 ビット版の Windows には，このレジストリエディタは存在しません．

32 ビット版の Windows のレジストリエディタは，RegEdit.exe または RegEdit コマンドだけで起動できます． 


C:\Windows\SysWOW64\Regedit


図10
64 ビットバージョンのレジストリの内容
  • [Wow6432Node] に 32 ビット版アプリの情報がある
図11
32 ビットバージョンのレジストリの内容
  • 64 ビットバージョンのレジストリの [Wow6432Node] と同じ内容が格納されている (全てではない)
  • 32 ビット版のレジストリエディタは [ファイル名を指定して実行] から C:\Windows\SysWOW64\Regedit で起動できる




06_レジストリへのアクセスとアプリの起動  -  32 ビットアプリから


実際のレジストリの操作として，レジストリの読み出しだけをテストしてみます．
読み出しだけであれは，特に管理者としての実行は必要ありません．起動するアプリが管理者権限実行されるかどうかは，このテストプログラムを管理者権限で実行するかどうかで決まります．

Delphi 自身は 32 ビットのアプリケーションです．そこで，ここでは，Windows 7 に標準で実装されている PowerShell を起動します．PowerShell は 32 ビット版と 64 ビット版があります．
PowerShell の実行ファイル名は，レジストリの下図の Path 項目に記録されています．

このテストは，64 ビット版の Windows のみで意味のある内容となっています．
Windows が 32 ビット版か 64 ビット版かの判定はしていません．



図12
PowwrShell

テストは以下の手順で行います．
  • (1) PowerShell の実行ファイル EXE のフルパスをレジストリから読み取る
  • (2) ShellExecuteEx 関数を使用して，PowerShell を起動する
  • (3) 起動したプロセスハンドルから実際に 32 bit 版か 64 bit 版なのかを判定する

このテストプログラムは，32 ビットのアプリケーションから，32 ビットと 64 ビットのレジストリから PowserShell の EXE のフルパスを取得します．
添付のサンプルプロジェクトは，ターゲットプラットフォームを 32 ビットとしています．

この方法は，システム関係内のフォルダにあるアプリケーションでは利用できるとは限りません．システム関係のアプリケーションは，基本的に，ファイルシステムのリダイレクト機能により，System32 フォルダを指定しても SysWOW64 フォルダ内をアクセスしてしまいます．
実行可能かの基準ついては筆者には分かりません．実行してみて確認するしかないようです．



図13
設計時画面
図14
32 ビット版を起動
  • [SysWOW64] 内の PowerShell が起動
図15
起動した 32 ビット版の PowerShell
  • カレントディレクトリは，このプロジェクトのフォルダ
図16
64 ビット版を起動
  • 確かに 64 ビット版となっている
図17
64 ビット版のフォルダ
  • [System32] となっている

リスト6
32 ビットアプリから 32 ビット版または 64 ビット版の PowerShell を起動		 
unit Unit1;

interface

uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants,
  System.Classes, Vcl.Graphics, Vcl.Controls, Vcl.Forms, Vcl.Dialogs,
  Vcl.StdCtrls;

type
  TForm1 = class(TForm)
    Button1: TButton;
    Button2: TButton;
    Edit1: TEdit;
    Button3: TButton;
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure Button3Click(Sender: TObject);
  private
    { Private 宣言 }
    FProcessHandle : Cardinal;
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

uses
  SHellAPI,
  Registry;

{$R *.dfm}

//----------------------------------------------------------------------------
//  ShellExecuteExでEXE実行
//  ShellExecuteExはファイル(拡張子)の関連付けでアプリを起動できる
//  SEE_MASK_NOCLOSEPROCESSは，ShellExecuteEx終了後もプロセスを実行したままにする
//  この指定がないとTShellExecuteInfo.Processでプロセスのハンドルが取得できない
//
//  ShellExcuteExの使用にはusesにShellAPIが必要
//----------------------------------------------------------------------------
function RunExeFile(hWnd: HWND; AFile: string; AParameters: string;
   Verb: string): Cardinal;
var
  LShellInfo : TShellExecuteInfo;
  LResult    : DWORD;
begin
  FillChar(LShellInfo, SizeOf(LShellInfo), 0);
  LShellInfo.cbSize := SizeOf(LShellInfo);
  LShellInfo.Wnd    := hWnd;
  LShellInfo.fMask  := SEE_MASK_NOCLOSEPROCESS or SEE_MASK_FLAG_NO_UI;
  LShellInfo.lpVerb := PChar(Verb);

  LShellInfo.lpFile       := PChar(AFile);
  LShellInfo.lpParameters := PChar(AParameters);
  LShellInfo.nShow        := SW_SHOW;

  ShellExecuteEx(@LShellInfo);

  //ShellExecuteExは成功するとhInstAppに33以上の値を返す
  if LShellInfo.hInstApp >= 33 then begin
    //起動終了まで待つための処理
    repeat
      LResult := WaitForInputIdle(LShellInfo.hProcess, 50);
      Application.ProcessMessages;
      Sleep(100);
    until LResult <> WAIT_TIMEOUT;
  end;
  //戻値は起動プロセスのハンドルとする
  Result := LShellInfo.hProcess;
end;

//=============================================================================
//  32bitアプリで，32bit版のアプリのフルパスをレジストリから取得
//  ここでは，32bit版のPowerShellのフルパスを取得
//
//  64ビット版Windows専用のコードなので注意
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
var
  LRegisry     : TRegistry;
  LAppKey      : string;
  LAppItem     : string;
  LAppFullPath : string;
  LIsWOW64     : BOOL;
  LStrText     : string;
begin
  LRegisry := TRegistry.Create;
  try
    //KEY_READ or KEY_WOW64_32KEY;のように32bitであることを明示してもよい
    LRegisry.Access  := KEY_READ;
    LRegisry.RootKey := HKEY_LOCAL_MACHINE;
    LAppKey   := 'SOFTWARE\Microsoft\PowerShell\1\ShellIds\Microsoft.PowerShell';
    LAppItem  := 'Path';

    if LRegisry.OpenKey(LAppKey, False) then begin
      try
        LAppFullPath := LRegisry.ReadString(LAppItem);
      finally
        LRegisry.CloseKey;
      end;
    end;
  finally
    FreeAndNil(LRegisry);
  end;

  Edit1.Text := LAppFullPath;

  //起動し，プロセスのハンドルを取得
  //独立起動とするので，第1引数を0とする
  FProcessHandle := RunExeFile(0, LAppFullPath, '', '');

  if FProcessHandle <> 0 then begin
    //起動したプロセスのビットバージョンを調査
    IsWow64Process(FProcessHandle, LIsWOW64);
    if LIsWOW64 then begin
      MessageBox(Handle, '32 ビット版です', 'PowerShell', MB_OK or MB_ICONASTERISK);
    end else begin
      MessageBox(Handle, '64 ビット版です', 'PowerShell', MB_OK or MB_ICONASTERISK);
    end;
  end else begin
    LStrText := 'PowerShell の起動に失敗しました';
    MessageBox(Handle, PChar(LStrText), 'PowerShell', MB_OK or MB_ICONASTERISK);
  end;
end;

//=============================================================================
//  32bitアプリで，64bit版のアプリのフルパスをレジストリから取得
//  ここでは，64bit版のPowerShellのフルパスを取得
//=============================================================================
procedure TForm1.Button2Click(Sender: TObject);
var
  LRegistry    : TRegistry;
  LAppKey      : string;
  LAppItem     : string;
  LAppFullPath : string;
  LIsWOW64     : BOOL;
  LStrText     : string;
begin
  LRegistry := TRegistry.Create;
  try
    //64bitのレジストリにアクセスするには，アクセスフラグにKEY_WOW64_64KEY指定する
    LRegistry.Access  := KEY_READ or KEY_WOW64_64KEY;
    LRegistry.RootKey := HKEY_LOCAL_MACHINE;
    LAppKey  := 'SOFTWARE\Microsoft\PowerShell\1\ShellIds\Microsoft.PowerShell';
    LAppItem := 'Path';

    if LRegistry.OpenKey(LAppKey, False) then begin
      try
        LAppFullPath := LRegistry.ReadString(LAppItem);
      finally
        LRegistry.CloseKey;
      end;
    end;
  finally
    FreeAndNil(LRegistry);
  end;

  Edit1.Text := LAppFullPath;

  //System32はSysnativeに置き換えないとリダイレクトしてしまう
  //Sysnativeは，32bitアプリから64bitのシステムフォルダへのアクセス用の仮想フォルダ
  LAppFullPath := StringReplace(LAppFullPath, 'System32', 'Sysnative', []);

  //起動し，プロセスのハンドルを取得
  //独立起動とするので，第1引数を0とする
  FProcessHandle := RunExeFile(0, LAppFullPath, '', '');

  if FProcessHandle <> 0 then begin
    //起動したプロセスのビットバージョンを調査
    IsWow64Process(FProcessHandle, LIsWOW64);
    if LIsWOW64 then begin
      MessageBox(Handle, '32ビット版です', 'PowerShell', MB_OK or MB_ICONASTERISK);
    end else begin
      MessageBox(Handle, '64ビット版です', 'PowerShell', MB_OK or MB_ICONASTERISK);
    end;
  end else begin
    LStrText := 'PowerShell の起動に失敗しました';
    MessageBox(Handle, PChar(LStrText), 'PowerShell', MB_OK or MB_ICONASTERISK);
  end;
end;

//=============================================================================
//  32bitアプリで，64bit版のアプリのフルパスをレジストリから取得
//  ここでは，64bit版のPowerShellのフルパスを取得
//  TRegistry.Createでレジストリへのアクセスフラグを指定する場合
//=============================================================================
procedure TForm1.Button3Click(Sender: TObject);
var
  LRegistry    : TRegistry;
  LAppKey      : string;
  LAppItem     : string;
  LAppFullPath : string;
  LIsWOW64     : BOOL;
  LStrText     : string;
begin
  //TRegistryのCreate時にアクセスフラグを指定する方法
  //64bitのレジストリにアクセスするには，アクセスフラグにKEY_WOW64_64KEY指定する
  LRegistry := TRegistry.Create(KEY_READ or KEY_WOW64_64KEY);
  try
    LRegistry.RootKey := HKEY_LOCAL_MACHINE;
    LAppKey  := 'SOFTWARE\Microsoft\PowerShell\1\ShellIds\Microsoft.PowerShell';
    LAppItem := 'Path';

    if LRegistry.OpenKey(LAppKey, False) then begin
      try
        LAppFullPath := LRegistry.ReadString(LAppItem);
      finally
        LRegistry.CloseKey;
      end;
    end;
  finally
    FreeAndNil(LRegistry);
  end;

  Edit1.Text := LAppFullPath;

  //System32はSysnativeに置き換えないとリダイレクトしてしまう
  //Sysnativeは，32bitアプリから64bitのシステムフォルダへのアクセス用の仮想フォルダ
  LAppFullPath := StringReplace(LAppFullPath, 'System32', 'Sysnative', []);

  //起動し，プロセスのハンドルを取得
  //独立起動とするので，第1引数を0とする
  FProcessHandle := RunExeFile(0, LAppFullPath, '', '');

  if FProcessHandle <> 0 then begin
    //起動したプロセスのビットバージョンを調査
    IsWow64Process(FProcessHandle, LIsWOW64);
    if LIsWOW64 then begin
      MessageBox(Handle, '32 ビット版です', 'PowerShell', MB_OK or MB_ICONASTERISK);
    end else begin
      MessageBox(Handle, '64 ビット版です', 'PowerShell', MB_OK or MB_ICONASTERISK);
    end;
  end else begin
    LStrText := 'PowerShell の起動に失敗しました';
    MessageBox(Handle, PChar(LStrText), 'PowerShell', MB_OK or MB_ICONASTERISK);
  end;
end;

end.



07_レジストリへのアクセスとアプリの起動  -  64 ビットアプリから


今度は，64 ビットのアプリから 32 ビットまたは 64 ビット版の PowerShell を起動します．
手順は前のサンプルと同じです．
添付のサンプルプロジェクトは，ターゲットプラットフォームを 64 ビットとしています．


図18
設計時画面
図19
32 ビット版を起動
  • 確かに 32 ビット版となっている
図20
32 ビット版のフォルダ
  • [SysWOW64] となっている
図21
64 ビット版を起動
  • [System32] となっている
図22
起動した 64 ビット版の PowerShell
  • カレントディレクトリは，プロジェクトのフォルダとなっている

リスト7
64 ビットアプリから 32 ビット版または 64 ビット版の PowerShell を起動		 
unit Unit1;

interface

uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants,
  System.Classes, Vcl.Graphics, Vcl.Controls, Vcl.Forms, Vcl.Dialogs,
  Vcl.StdCtrls;

type
  TForm1 = class(TForm)
    Button1: TButton;
    Button2: TButton;
    Edit1: TEdit;
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
  private
    { Private 宣言 }
    ProcessHandle : Cardinal;
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

uses
  SHellAPI,
  Registry;

{$R *.dfm}

//----------------------------------------------------------------------------
//  ShellExecuteExでEXE実行
//  ShellExecuteExはファイル(拡張子)の関連付けでアプリを起動できる
//  SEE_MASK_NOCLOSEPROCESSは，ShellExecuteEx終了後もプロセスを実行したままにする
//  この指定がないとTShellExecuteInfo.Processでプロセスのハンドルが取得できない
//
//  ShellExcuteExの使用にはusesにShellAPIが必要
//----------------------------------------------------------------------------
function RunExeFile(hWnd: HWND; AFile: string; AParameters: string;
   Verb: string): Cardinal;
var
  LShellInfo : TShellExecuteInfo;
  LResult    : DWORD;
begin
  FillChar(LShellInfo, SizeOf(LShellInfo), 0);
  LShellInfo.cbSize := SizeOf(LShellInfo);
  LShellInfo.Wnd    := hWnd;
  LShellInfo.fMask  := SEE_MASK_NOCLOSEPROCESS or SEE_MASK_FLAG_NO_UI;
  LShellInfo.lpVerb := PChar(Verb);

  LShellInfo.lpFile       := PChar(AFile);
  LShellInfo.lpParameters := PChar(AParameters);
  LShellInfo.nShow        := SW_SHOW;

  ShellExecuteEx(@LShellInfo);

  //ShellExecuteExは成功するとhInstAppに33以上の値を返す
  if LShellInfo.hInstApp >= 33 then begin
    //起動終了まで待つための処理
    repeat
      LResult := WaitForInputIdle(LShellInfo.hProcess, 50);
      Application.ProcessMessages;
      Sleep(100);
    until LResult <> WAIT_TIMEOUT;
  end;
  //戻値は起動プロセスのハンドルとする
  Result := LShellInfo.hProcess;
end;

//=============================================================================
//  64bitアプリで，32bit版のアプリのフルパスをレジストリから取得
//  ここでは，32bit版のPowerShellのフルパスを取得
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
var
  LRegistry    : TRegistry;
  LAppKey      : string;
  LAppItem     : string;
  LAppFullPath : string;
  LIsWOW64     : BOOL;
  LStrText     : string;
begin
  LRegistry := TRegistry.Create;
  try
    //32bitのレジストリにアクセスするには，アクセスフラグにKEY_WOW64_32KEY指定する
    LRegistry.Access  := KEY_READ or KEY_WOW64_32KEY;
    LRegistry.RootKey := HKEY_LOCAL_MACHINE;
    LAppKey  := 'SOFTWARE\Microsoft\PowerShell\1\ShellIds\Microsoft.PowerShell';
    LAppItem := 'Path';

    if LRegistry.OpenKey(LAppKey, False) then begin
      try
        LAppFullPath := LRegistry.ReadString(LAppItem);
      finally
        LRegistry.CloseKey;
      end;
    end;
  finally
    FreeAndNil(LRegistry);
  end;

  Edit1.Text := LAppFullPath;

  //起動し，プロセスのハンドルを取得
  //独立起動とするので，第1引数を0とする
  ProcessHandle := RunExeFile(0, LAppFullPath, '', '');

  if ProcessHandle <> 0 then begin
    //起動したプロセスのビットバージョンを調査
    IsWow64Process(ProcessHandle, LIsWOW64);
    if LIsWOW64 then begin
      MessageBox(Handle, '32 ビット版です', 'PowerShell', MB_OK or MB_ICONASTERISK);
    end else begin
      MessageBox(Handle, '64 ビット版です', 'PowerShell', MB_OK or MB_ICONASTERISK);
    end;
  end else begin
    LStrText := 'PowerShell の起動に失敗しました';
    MessageBox(Handle, PChar(LStrText), 'PowerShell', MB_OK or MB_ICONASTERISK);
  end;
end;

//=============================================================================
//  64bitアプリで，64bit版のアプリのフルパスをレジストリから取得
//  ここでは，64bit版のPowerShellのフルパスを取得
//=============================================================================
procedure TForm1.Button2Click(Sender: TObject);
var
  LRegistry    : TRegistry;
  LAppKey      : string;
  LAppItem     : string;
  LAppFullPath : string;
  LIsWOW64     : BOOL;
  LStrText     : string;
begin
  LRegistry := TRegistry.Create;
  try
    //KEY_WOW64_64KEYがなくても，64bitアプリでは64bitのレジストリにアクセスする
    LRegistry.Access  := KEY_READ or KEY_WOW64_64KEY;
    LRegistry.RootKey := HKEY_LOCAL_MACHINE;
    LAppKey  := 'SOFTWARE\Microsoft\PowerShell\1\ShellIds\Microsoft.PowerShell';
    LAppItem := 'Path';

    if LRegistry.OpenKey(LAppKey, False) then begin
      try
        LAppFullPath := LRegistry.ReadString(LAppItem);
      finally
        LRegistry.CloseKey;
      end;
    end;
  finally
    FreeAndNil(LRegistry);
  end;

  Edit1.Text := LAppFullPath;

  //起動し，プロセスのハンドルを取得
  //独立起動とするので，第1引数を0とする
  ProcessHandle := RunExeFile(0, LAppFullPath, '', '');

  if ProcessHandle <> 0 then begin
    //起動したプロセスのビットバージョンを調査
    IsWow64Process(ProcessHandle, LIsWOW64);
    if LIsWOW64 then begin
      MessageBox(Handle, '32 ビット版です', 'PowerShell', MB_OK or MB_ICONASTERISK);
    end else begin
      MessageBox(Handle, '64 ビット版です', 'PowerShell', MB_OK or MB_ICONASTERISK);
    end;
  end else begin
    LStrText := 'PowerShell の起動に失敗しました';
    MessageBox(Handle, PChar(LStrText), 'PowerShell', MB_OK or MB_ICONASTERISK);
  end;
end;

end.