(*--▽---------------------------▼--
シェルユニット
2005/11/09
・GetOperationFilesName/ForceCopyFileなどを追加した
・ForceXXXFile/Folder系は単一ファイル/フォルダでのテストは完了している
  SHXXXFile/Dir系は動作試験をしていないのでForce系を使うのがよいだろう
2010/03/25(木)
・ファイル操作系の関数群をShellFileCtrl.pasへ移動した
//--▲---------------------------△--*)
unit ShellUnit;

interface

uses
  SysUtils,
  Windows,
  Registry,
  Classes,
  ShellAPI,
  Messages,     //WM_NULL

  SystemUnit, //DebugPrint

end_uses;
(*----------------------------------------
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; hWnd: HWND=0);
procedure EasyShellExecuteCmdLine(CommandLine: String; Show: Boolean=True); overload;
procedure EasyShellExecuteCmdLine(CommandLine, Parameters: String; Show: Boolean=True); overload;

procedure EasyShellExecuteEx(hwnd: HWND; TargetFile: String; Parameters: String;
  Modal: Boolean=False; 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


//-------------------------------
//ShellExecuteを簡単に呼び出します
//uses ShellAPIを追加してください
//openの定義が正しく無いときやopenが標準ではないときに
//正しく動作しない事があるようです。2006/12/18(月) 18:57
procedure EasyShellExecute(TargetFile: String; Show: Boolean=True; hWnd: HWND=0);
var
  FileName, FilePath: String;
begin
  FileName := ExtractFileName(TargetFile);
  FilePath := ExtractFilePath(TargetFile);
  if Show then
    ShellExecute( hWnd, 'open', PChar(FileName), nil, PChar(FilePath), SW_SHOW)
  else
    ShellExecute( hWnd, '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;
//※コマンドライン引数を渡してもうまく動かない。
//    EasyShellExecuteCmdLine(IncludeLastPathDelim(AppFolderPath) +
//      'ShowCmdLine.exe');
//上記はOKだが、
//    EasyShellExecuteCmdLine(IncludeLastPathDelim(AppFolderPath) +
//      'ShowCmdLine.exe test');
//上記はダメ。

procedure EasyShellExecuteCmdLine(CommandLine, Parameters: String; Show: Boolean=True);
begin
  if Show then
    ShellExecute( 0, nil, PChar(CommandLine), PChar(Parameters), nil, SW_SHOW)
  else
    ShellExecute( 0, nil, PChar(CommandLine), PChar(Parameters), nil, SW_HIDE)
end;

{-------------------------------
//      EasyShellExecuteEx
機能:       ShellExecuteExを呼び出す
			終了間待ちが可能
備考:
履歴:       2010/02/11(木)
			  作成
//--▼----------------------▽--}
procedure EasyShellExecuteEx(hwnd: HWND; TargetFile: String; Parameters: String;
  Modal: Boolean=False; Show: Boolean=True);
var
  SXInfo: TShellExecuteInfo;
  ecode: Integer;
begin
  with SXInfo do//TShellExecuteInfo構造体の初期化
  begin
    cbSize := SizeOf( SXInfo);
    fMask := SEE_MASK_NOCLOSEPROCESS;//これがないと終了待ち出来ない
    Wnd := hwnd;
    lpVerb := 'open';
    lpFile := PChar(TargetFile);
    if Parameters = '' then lpParameters := Nil
                       else lpParameters := PChar(Parameters);
    lpDirectory := Nil;
	if Show then nShow := SW_SHOW
			else nShow := SW_HIDE;
  end;

  ShellExecuteEx( @SXInfo);

//  if Modal then
//  begin
//    起動したアプリケーションの終了待ち
//    while WaitForSingleObject( SXInfo.hProcess, 0) = WAIT_TIMEOUT do
//    begin
//      //Application.ProcessMessages;
//      //Sleep(100);
//    end;
//  end;

  if Modal then
  begin
    while True do
    begin
      ecode := WaitForSingleObject( SXInfo.hProcess, 10);

      {↓メッセージループを回してウェイトを入れている}
      hwnd := FindWindow( 'Progman', nil);
      //if isWindow(hwnd) then
        SendMessage(hwnd, WM_NULL, 0, 0);

      //DebugPrintEmEditor(IntToStr(ecode));
      if ecode = WAIT_OBJECT_0 then break;
    end;
  end;

//  if Modal then
//  begin
//    for i := 0 to INFINITE do begin
//      ecode := WaitForSingleObject(SXInfo.hProcess, 100);
//      if ecode = WAIT_OBJECT_0 then
//      begin
//        //MessageBox(0, 'test', 'test', MB_OK);
//        DebugPrintEmEditor('Modal');
//        break;
//      end;
//    end;
//    DebugPrintEmEditor(IntToStr(ecode));
//  end;
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.