(*-----------------------------------
シェルユニット
2005/11/09
・GetOperationFilesName/ForceCopyFileなどを追加した
・ForceXXXFile/Folder系は単一ファイル/フォルダでのテストは完了している
  SHXXXFile/Dir系は動作試験をしていないのでForce系を使うのがよいだろう
//-----------------------------------*)
unit ShellUnit;

interface

uses
  SysUtils,
  Windows,
  Registry,
  Classes,
  ShellAPI;

function GetOperationFilesName(Files: TStrings): String;
function ForceCopyFile(hParent: HWND; FromFileName, ToFileName: String):Boolean;
function ForceMoveFile(hParent: HWND; FromFileName, ToFileName: String):Boolean;
function ForceDeleteFile(hParent: HWND; FromFileName: String):Boolean;
function ForceRecyslerFile(hParent: HWND; FromFileName: String):Boolean;

function ForceCopyAllFiles(hParent: HWND; FromFolderName, ToFolderName: String):Boolean;
function ForceMoveAllFiles(hParent: HWND; FromFolderName, ToFolderName: String):Boolean;
function ForceDeleteAllFiles(hParent: HWND; FromFolderName: String):Boolean;

function ForceCopyFolder(hParent: HWND; NameFrom, NameTo: String):Boolean;
function ForceMoveFolder(hParent: HWND; NameFrom, NameTo: String):Boolean;
function ForceDeleteFolder(hParent: HWND; NameFrom: String):Boolean;

function SHCopyFile(hParent:HWND;NameFrom,NameTo:string):Boolean;
function SHMoveFile(hParent:HWND;NameFrom,NameTo:string):Boolean;
function SHRenameFile(hParent:HWND;NameFrom,NameTo:string):Boolean;
function SHDeleteFile(hParent:HWND;Name:string):Boolean;
function SHCopyDir(hParent:HWND;NameFrom,NameTo:string):Boolean;
function SHMoveDir(hParent:HWND;NameFrom,NameTo:string):Boolean;
function SHDeleteDir(hParent:HWND;Name:string):Boolean;

procedure EasyShellExecute(TargetFile: String; Show: Boolean = True);
procedure EasyShellExecuteCmdLine(CommandLine: String; Show: Boolean=True);

type
  TOpenFolderCommand = (ofcDefault, ofcOpen, ofcExplorer);
procedure OpenFolderShell(FolderPath: String; Command: TOpenFolderCommand = ofcDefault);
type
  TExplorerExecute = (eeNewWindow, eeFolderTree, eeSelectFile, eeRoot);
  TExplorerExecutes= set of TExplorerExecute;
procedure OpenFolder(TargetPath: String; Option: TExplorerExecutes);

function ExtRunExeFileName(FileName: String): String;

implementation

//SHFileOperationで使える形式の複数ファイル指定を行う関数
function GetOperationFilesName(Files: TStrings): String;
var
  i: Integer;
begin
  Result := '';
  for i := 0 to Files.Count-1 do
  begin
    Result := Result + Files[i] + #0
  end;
  if Result <> '' then
  begin
    Result := Result + #0;
  end;
end;

//文字列の最後を#0#0とする関数
function SetDoubleNullLastChar(s: String): String;
var
  SetNullChar: String;
begin
//  if 1 <= Length(s) then
//  begin
//    if s[Length(s)] <> #0 then
//    begin
//      SetNullChar := #0#0;
//    end else
//    begin
//      if
//      SetNullChar
//    end;
//  end else
//  begin
//    SetNullChar := #0#0;
//  end;

  if 2 <= Length(s) then
  begin
    if s[Length(s)] = #0 then
    begin
      if s[Length(s)-1] = #0 then
      begin
        Result := s;
      end else
      begin
        Result := s + #0;
      end;
    end else
    begin
      Result := s + #0#0;
    end;
  end else
  if 1 = Length(s) then
  begin
    if s[1] = #0 then
    begin
      Result := s + #0;
    end else
    begin
      Result := s + #0#0;
    end;
  end else
  begin
    Result := #0#0;
  end;
end;

function ShellFileOperation(hParent:HWND; FromName, ToName: String;
 Func: UINT; Flags: FILEOP_FLAGS): Boolean;
var
  SFO: TSHFileOpStruct;
begin
  FromName := SetDoubleNullLastChar(FromName);
  ToName := SetDoubleNullLastChar(ToName);
  with SFO do begin
    Wnd := hParent;
    wFunc := Func;
    pFrom := PChar(FromName);
	if Func = FO_DELETE then
      pTo := nil
    else
      pTo := PChar(ToName);
    fFlags := Flags;
    fAnyOperationsAborted := false;
        //処理が終了する前にユーザーが中断させた場合にTRUEが返される
    hNameMappings := nil;
        //fFlagsがFOF_WANTMAPPINGHANDLEを含む時使用され、
        //TSHNameMapping構造体（後述）の配列を含むファイルネームマッピングオブジェクトのハンドル
    lpszProgressTitle := nil;
        //fFlagsがFOF_SIMPLEPROGRESSを含む時使用され、
        //進捗ダイアログボックスのタイトル文字列へのポインタ
  end;
  Result := not Boolean(SHFileOperation(SFO));
end;
//ShellAPI.pasから抜粋
//  FO_MOVE           = $0001;
//  FO_COPY           = $0002;
//  FO_DELETE         = $0003;
//  FO_RENAME         = $0004;  実際にはRenameは使わないと思う
//
//  FOF_MULTIDESTFILES         = $0001;
//      pTo に複数設定するときに指定
//      デスティネーションファイル・ディレクトリを複数指定する
//  FOF_CONFIRMMOUSE           = $0002;//設定不可|未実装
//  FOF_SILENT                 = $0004;
//      プログレスダイアログを表示しない
//      進捗ダイアログボックスを表示しない
//  FOF_RENAMEONCOLLISION      = $0008;
//      既存ファイル名との衝突のとき新しい名前にする
//      既に同じファイル名が存在する場合「のコピー」というファイル名を与える
//  FOF_NOCONFIRMATION         = $0010;
//      表示されるダイアログに「すべてはい」と自動的に答える
//      表示されるダイアログボックスに「全てはい」を選択
//  FOF_WANTMAPPINGHANDLE      = $0020;  { Fill in SHFILEOPSTRUCT.hNameMappings
//                                         Must be freed using SHFreeNameMappings }
//      hNameMappingsを使用（ハンドルはSHFreeNameMappings関数で開放）
//  FOF_ALLOWUNDO              = $0040;
//      「元に戻す」を有効にする
//      可能ならアンドゥー情報を保持する
//  FOF_FILESONLY              = $0080;
//      ワイルドカード *.* ではファイルのみに操作を限定
//      ワイルドカード（*.*）が指定された場合、ファイルに対してのみ操作を行う
//  FOF_SIMPLEPROGRESS         = $0100;
//      プログレスダイアログにファイル名を表示しない  
//      進捗ダイアログボックスを表示（ファイル名は表示せず）
//  FOF_NOCONFIRMMKDIR         = $0200;
//      ディレクトリを作るときでも「確認」しない  
//      必要があれば新しいディレクトリを自動的に作成
//  FOF_NOERRORUI              = $0400;
//      エラーUIを表示しない

function ForceCopyFile(hParent: HWND; FromFileName, ToFileName: String):Boolean;
begin
  if FileExists(FromFileName) then
  begin
    ShellFileOperation(hParent, FromFileName, ToFileName, FO_COPY,
      FOF_SILENT or FOF_NOCONFIRMATION or FOF_NOCONFIRMMKDIR);
  end;
//※or FOF_NOCONFIRMMKDIR or FOF_NOERRORUIとすると
//  コピー時にフォルダを作成してくれない
//  FOF_NOERRORUIはいれなくてよい
end;

function ForceMoveFile(hParent: HWND; FromFileName, ToFileName: String):Boolean;
begin
  if FileExists(FromFileName) then
  begin
    ShellFileOperation(hParent, FromFileName, ToFileName, FO_MOVE,
      FOF_SILENT or FOF_NOCONFIRMATION or FOF_NOCONFIRMMKDIR);
  end;
end;

function ForceDeleteFile(hParent: HWND; FromFileName: String):Boolean;
begin
  if FileExists(FromFileName) then
  begin
    ShellFileOperation(hParent, FromFileName, '', FO_DELETE,
      FOF_SILENT or FOF_NOCONFIRMATION);
  end;
end;

function ForceRecyslerFile(hParent: HWND; FromFileName: String):Boolean;
begin
  if FileExists(FromFileName) then
  begin
    ShellFileOperation(hParent, FromFileName, '', FO_DELETE,
      FOF_SILENT or FOF_NOCONFIRMATION or FOF_ALLOWUNDO);
  end;
end;

function ForceCopyAllFiles(hParent: HWND; FromFolderName, ToFolderName: String):Boolean;
begin
  if DirectoryExists(FromFolderName)
    and DirectoryExists(ToFolderName) then
  begin
    FromFolderName := FromFolderName + PathDelim + '*.*';
    ShellFileOperation(hParent, FromFolderName, ToFolderName, FO_COPY,
      FOF_SILENT or FOF_NOCONFIRMATION or FOF_NOCONFIRMMKDIR);
  end;
//※or FOF_NOCONFIRMMKDIR or FOF_NOERRORUIとすると
//  コピー時にフォルダを作成してくれない
//  FOF_NOERRORUIはいれなくてよい
end;

function ForceMoveAllFiles(hParent: HWND; FromFolderName, ToFolderName: String):Boolean;
begin
  if DirectoryExists(FromFolderName)
    and DirectoryExists(ToFolderName) then
  begin
    FromFolderName := FromFolderName + PathDelim + '*.*';
    ShellFileOperation(hParent, FromFolderName, ToFolderName, FO_MOVE,
      FOF_SILENT or FOF_NOCONFIRMATION or FOF_NOCONFIRMMKDIR);
  end;
end;

function ForceDeleteAllFiles(hParent: HWND; FromFolderName: String):Boolean;
begin
  if DirectoryExists(FromFolderName) then
  begin
    FromFolderName := FromFolderName + PathDelim + '*.*';
    ShellFileOperation(hParent, FromFolderName, '', FO_DELETE,
      FOF_SILENT or FOF_NOCONFIRMATION);
  end;
end;


function ForceCopyFolder(hParent: HWND; NameFrom, NameTo: String):Boolean;
begin
  if DirectoryExists(NameFrom) then
  begin
    ForceDirectories(ExtractFileDir(NameTo));
    ShellFileOperation(hParent, NameFrom, NameTo, FO_COPY,
      FOF_SILENT or FOF_NOCONFIRMATION or FOF_NOCONFIRMMKDIR);
  end;
//※なぜかフォルダ指定のコピーの場合はFOF_NOCONFIRMMKDIRが
//  動作しないようなので一つ上のフォルダを
//  ForceDirectorysで作成する。
end;

function ForceMoveFolder(hParent: HWND; NameFrom, NameTo: String):Boolean;
begin
  if DirectoryExists(NameFrom) then
  begin
    ShellFileOperation(hParent, NameFrom, NameTo, FO_MOVE,
      FOF_SILENT or FOF_NOCONFIRMATION or FOF_NOCONFIRMMKDIR);
  end;
//NameToが存在している場合は
//NameFromフォルダがNameToフォルダの中に入ってしまう事になる
end;

function ForceDeleteFolder(hParent: HWND; NameFrom: String):Boolean;
begin
  if DirectoryExists(NameFrom) then
  begin
    ShellFileOperation(hParent, NameFrom, '', FO_DELETE,
      FOF_SILENT or FOF_NOCONFIRMATION);
  end;
end;


////////////////////////////////////////////////////////////
function SHCopyFile(hParent:HWND;NameFrom,NameTo:string):Boolean;
var
  SFO: TSHFileOpStruct;
begin
  NameFrom := NameFrom+#0#0;
  NameTo := NameTo+#0#0;
  with SFO do begin
    Wnd := hParent;
    wFunc := FO_COPY;
    pFrom := PChar(NameFrom);
    pTo := PChar(NameTo);
    fFlags := FOF_ALLOWUNDO;
    fAnyOperationsAborted := false;
    hNameMappings := nil;
    lpszProgressTitle := nil;
  end;
  Result := not Boolean(SHFileOperation(SFO));
end;

function SHMoveFile(hParent:HWND;NameFrom,NameTo:string):Boolean;
var
  SFO: TSHFileOpStruct;
begin
  NameFrom := NameFrom+#0#0;
  NameTo := NameTo+#0#0;
  with SFO do begin
    Wnd := hParent;
    wFunc := FO_MOVE;
    pFrom := PChar(NameFrom);
    pTo := PChar(NameTo);
    fFlags := FOF_ALLOWUNDO;
    fAnyOperationsAborted := false;
    hNameMappings := nil;
  end;
  Result := not Boolean(SHFileOperation(SFO));
end;

function SHRenameFile(hParent:HWND;NameFrom,NameTo:string):Boolean;
var
  SFO: TSHFileOpStruct;
begin
  NameFrom := NameFrom+#0#0;
  NameTo := NameTo+#0#0;
  with SFO do begin
    Wnd := hParent;
    wFunc := FO_RENAME;
    pFrom := PChar(NameFrom);
    pTo := PChar(NameTo);
    fFlags := FOF_ALLOWUNDO;
    fAnyOperationsAborted := false;
    hNameMappings := nil;
  end;
  Result := not Boolean(SHFileOperation(SFO));
end;

function SHDeleteFile(hParent:HWND;Name:string):Boolean;
var
  SFO: TSHFileOpStruct;
begin
  Name := Name+#0#0;
  with SFO do begin
    Wnd := hParent;
    wFunc := FO_DELETE;
    pFrom := PChar(Name);
    pTo := nil;
    fFlags := FOF_ALLOWUNDO + FOF_NOCONFIRMATION;
    fAnyOperationsAborted := false;
    hNameMappings := nil;
  end;
  Result := not Boolean(SHFileOperation(SFO));
end;


function SHCopyDir(hParent:HWND;NameFrom,NameTo:string):Boolean;
var
  SFO: TSHFileOpStruct;
begin
  NameFrom := NameFrom+#0#0;
  NameTo := NameTo+#0#0;
  with SFO do begin
    Wnd := hParent;
    wFunc := FO_COPY;
    pFrom := PChar(NameFrom);
    pTo := PChar(NameTo);
    fFlags := FOF_ALLOWUNDO or FOF_NOCONFIRMMKDIR;
    fAnyOperationsAborted := false;
    hNameMappings := nil;
  end;
  Result := not Boolean(SHFileOperation(SFO));
end;

function SHMoveDir(hParent:HWND;NameFrom,NameTo:string):Boolean;
var
  SFO: TSHFileOpStruct;
begin
  NameFrom := NameFrom+#0#0;
  NameTo := NameTo+#0#0;
  with SFO do begin
    Wnd := hParent;
    wFunc := FO_MOVE;
    pFrom := PChar(NameFrom);
    pTo := PChar(NameTo);
    fFlags := FOF_ALLOWUNDO or FOF_NOCONFIRMMKDIR or FOF_SILENT ;
    fAnyOperationsAborted := false;
    hNameMappings := nil;
  end;
  Result := not Boolean(SHFileOperation(SFO));
end;


function SHDeleteDir(hParent:HWND;Name:string):Boolean;
var
  SFO: TSHFileOpStruct;
begin
  Name := Name+#0#0;
  with SFO do begin
    Wnd := hParent;
    wFunc := FO_DELETE;
    pFrom := PChar(Name);
    pTo := nil;
    fFlags := FOF_ALLOWUNDO + FOF_NOCONFIRMATION or FOF_SILENT ;
    fAnyOperationsAborted := false;
    hNameMappings := nil;
  end;
  Result := not Boolean(SHFileOperation(SFO));
end;


//-------------------------------
//ShellExecuteを簡単に呼び出します
//uses ShellAPIを追加してください
//openの定義が正しく無いときやopenが標準ではないときに
//正しく動作しない事があるようです。2006/12/18(月) 18:57
procedure EasyShellExecute(TargetFile: String; Show: Boolean=True);
var
  FileName, FilePath: String;
begin
  FileName := ExtractFileName(TargetFile);
  FilePath := ExtractFilePath(TargetFile);
  if Show then
    ShellExecute( 0, 'open', PChar(FileName), nil, PChar(FilePath), SW_SHOW)
  else
    ShellExecute( 0, 'open', PChar(FileName), nil, PChar(FilePath), SW_HIDE)
end;


//-------------------------------
//ShellExecuteを簡単に呼び出します
//uses ShellAPIを追加してください
procedure EasyShellExecuteCmdLine(CommandLine: String; Show: Boolean=True);
begin
  if Show then
    ShellExecute( 0, nil, PChar(CommandLine), nil, nil, SW_SHOW)
  else
    ShellExecute( 0, nil, PChar(CommandLine), nil, nil, SW_HIDE)
end;

{-------------------------------
//  フォルダを開く
機能:       OpenFolderShell
              Shell起動でopenかexplorerを選択してフォルダを開く
            OpenFolder
              CreateProcessでオプション指定してエクスプローラを起動
引数:       Option 集合型で指定
              eeNewWindow   新しいWindowを開いてフォルダを開く
              eeFolderTree  フォルダーツリーを開く(必ず新しいWindowになる)
              eeSelectFile  ファイル/フォルダを選択した状態でフォルダを開く
備考:       ShellExecute版にはuses ShellAPIが必要
            CreateProcessにはWaitForSingleObjectの終了待ち処理は無効
            2005/05/01
              Explorer拡張子指定方法
              想像部分も多いのだが/e指定すると/n指定は意味がなくなり
              /select指定と/root指定は同時に指定してもうまく動かない
              (なんかデスクトップが開く)要注意！
履歴:       2001/11/09
            2003/02/15
              ShellExecuteのハンドルを0にして
              Applicationオブジェクトがない場合でも動作可能にした
            2003/08/18
              /selectオプションで開く関数
              FolderOpenSelectFileCreateProcessを追加
            2003/09/21
              FolderOpenCreateProcessをOpenFolderに変更
              FolderOpenShellExecuteのオプションをBooleanに変更
            2005/05/01
              eeRoot指定処理を追加した
            2006/07/14
              FolderOpenShellExecuteをOpenFolderShellに名前変更
              OpenFolderShellにDefaultで開くコマンドを用意
              OpenFolderShellで動作を確認した
参考:
    http://opt-1.matsc.kyutech.ac.jp/explorer.html

    Windowsレジストリ操作方法
    http://www.wwlnk.com/boheme/delphi/techdoc/dad0050.html
//------------------------------}
procedure OpenFolderShell(FolderPath: String; Command: TOpenFolderCommand = ofcDefault);
var
  Reg: TRegistry;

  SXInfo: TShellExecuteInfo;
begin
  if DirectoryExists(FolderPath) then
  begin
    FolderPath := ExcludeTrailingPathDelimiter(FolderPath);

    case Command of
    ofcDefault:
    begin

(*-----------------------------------
//ダメ
      with SXInfo do//TShellExecuteInfo構造体の初期化
      begin
        cbSize := SizeOf( SXInfo);
//        fMask := SEE_MASK_IDLIST;//
//        fMask := SEE_MASK_NOCLOSEPROCESS;//これがないと終了待ち出来ない
//        fMask := SEE_MASK_INVOKEIDLIST;
        Wnd := 0;
        lpVerb := 'OpenWithMDIE';
        lpFile := PChar(FolderPath);
        lpParameters := Nil;
        lpDirectory := Nil;
        nShow := SW_SHOW;
      end;


      ShellExecuteEx( @SXInfo);

      //起動したアプリケーションの終了待ち
//      while WaitForSingleObject( SXInfo.hProcess, 0) = WAIT_TIMEOUT do
//        Application.ProcessMessages;
//-----------------------------------*)


(*-----------------------------------
//だめだ、動かない
      OpenFolderDefault := '';
      Reg := TRegistry.Create;
      Reg.Rootkey  :=  HKEY_CLASSES_ROOT;
      //以下のキーを開きます。無い場合は false を返します。
      if Reg.OpenKey('\Folder\shell', False)then
      begin
        OpenFolderDefault := Reg.ReadString('');
        Reg.CloseKey;
      end;

      if OpenFolderDefault <> '' then
      begin
        ShellExecute(0, PChar('OpenWithMDIE'),
          PChar(FolderPath), nil, nil, SW_SHOW);
      end else
      begin
        ShellExecute(0,
          PChar('open'), PChar(FolderPath), nil, nil, SW_SHOW);
      end;
//-----------------------------------*)

//(*-----------------------------------
      //本来はこの程度の処理ですむはずが
      //フォルダのパス指定のみで起動しようとすると
      //正しくファイラーが開かない(Win2Kで誤動作する)
      ShellExecute(0,
        nil, PChar('"'+FolderPath+'"'), nil, nil, SW_SHOW);
//-----------------------------------*)

    end;

    ofcOpen:
      ShellExecute(0,
        PChar('open'), PChar(FolderPath), nil, nil, SW_SHOW);

    ofcExplorer:
      ShellExecute(0,
        PChar('explore'), PChar(FolderPath), nil, nil, SW_SHOW);
    end;
  end else
  begin
    raise Exception.Create('フォルダではありません'+#13+FolderPath);
  end;
end;

procedure OpenFolder(TargetPath: String; Option: TExplorerExecutes);
var
  si: TStartupInfo;
  pi: TProcessInformation;
  CmdExplorer: String;
begin
  CmdExplorer := 'Explorer.exe ';
  if eeNewWindow in Option then
  begin
    CmdExplorer := CmdExplorer + '/n, ';
  end;

  if eeFolderTree in Option then
  begin
    CmdExplorer := CmdExplorer + '/e, ';
  end;

  if eeSelectFile in Option then
  begin
    CmdExplorer := CmdExplorer + '/select, ';
  end else
  begin
    if FileExists(TargetPath) then
    TargetPath := ExtractFileDir(TargetPath);
    {↑/select指定なしでファイル指定されたら変な動作になるので
       フォルダ指定に変更している}
  end;
  
  if eeRoot in Option then
  begin
    CmdExplorer := CmdExplorer + '/root, ';
    if FileExists(TargetPath) then
    TargetPath := ExtractFileDir(TargetPath);
    {↑/root指定でファイル指定されたら動作しないので
       フォルダ指定に変更している}
  end;

  if (eeSelectFile in Option) and (eeRoot in Option) then
  begin
    raise Exception.Create('/selectと/rootは同時に指定できません');
  end;
  
  // TStartupInfo構造体の初期化
  FillChar(si, Sizeof(TStartupInfo), 0);
  si.cb := Sizeof(TStartupInfo);

  CmdExplorer := CmdExplorer + '"' + TargetPath + '"';
  CreateProcess(nil,PChar(CmdExplorer),nil,nil, True,0,nil,nil,si,pi);
end;
//------------------------------

{-------------------------------
//  拡張子で関連づいた実行ファイルのパスを調べます
引数説明:   FileName: 調べたいファイルのフルパスを指定
戻り値:     関連づいたexeファイルのパス。
            ショートファイル名になります。
            例  C:\PROGRA~1\INTERN~1\iexplore.exe
            ファイルが存在しなかったり関連付けが見つからない場合は
            ''を戻します
備考:       uses ShellAPIを追加
            FindExecutableは2種類の方法で呼び出せる
            フルパスを指定
              FindExecutable(PChar(FileName), nil, AppName);
            基準パスと相対パス(./test.txt等)を指定
            　FindExecutable(PChar(RelativeName), PChar(BasePath), AppName);　
履歴:       2000/11/30
            2003/11/11 DFindExecutable1/2から名前を変更して実装
//------------------------------}
function ExtRunExeFileName(FileName: String): String;
var
  AppName: array[0..MAX_PATH] of Char;
  AppHandle: THandle;
begin
  AppHandle := FindExecutable(PChar(FileName), nil, AppName);
  if AppHandle > 32 then
    Result := AppName
  else
    Result := '';
end;

(*-----------------------------------
function FindExeFileName(const Target: String): String;
var
  S: String;
  PC: PChar;
begin
  Result := '';
  GetMem(PC,MAX_PATH);
  try
    if FindExecutable(PChar(Target),
                             PChar(GetCurrentDir),PC) > 32 then
    begin
      SetString(S,PC,StrLen(PC));
      Result := S;
    end;
  finally
    FreeMem(PC);
  end;
end;
//-----------------------------------*)
//------------------------------

end.