Ожидание завершения процесса

[Человек-Ололо]

Программа работает с RAM-дисками, которая сама же и монтирует, используя установленный в системе драйвер от imDisk. Монтирование вызывается через следующую функцию:

function TForm1.waitProcess(com:string;show:cardinal): boolean; {Запуск процессов с ожиданием}
var   CLI: LongBool;
      StartUpInfo: TStartUpInfo;
      ProcessInfo: TProcessInformation;
begin
  FillChar(StartUpInfo, SizeOf(TStartUpInfo), 0);
  with StartUpInfo do
  begin
    cb := SizeOf(TStartUpInfo);
    dwFlags := STARTF_USESHOWWINDOW or STARTF_FORCEONFEEDBACK;
    wShowWindow := show;
  end;
  CLI := CreateProcess(nil, PChar(cli), nil, nil, false, NORMAL_PRIORITY_CLASS, nil, nil, StartUpInfo, ProcessInfo);
  if not CLI then
    Result := False
  else begin
    with ProcessInfo do begin
      WaitForInputIdle(hProcess, INFINITE);
      WaitforSingleObject(hProcess, INFINITE);
      CloseHandle(hThread);
      CloseHandle(hProcess);
    end;
    Result := True;
  end;
end;

В принципе, стандартный метод, описанный на десятке сайтов. Проблема же в следующем: если вызывать ту же строчку в командной строке ручками, то выполнение команды занимает чуть более секунды и диск уже смонтирован:

Creating device...
Created device 1: v: -> VM ima
Formatting disk...
Тип файловой системы: RAW.
Новая файловая система: NTFS.
Быстрое форматирование: 128 МБ
Создание структур файловой сис
Форматирование окончено.
     128,0 МБ всего на диске.
     125,8 МБ доступно.
Notifying applications...
Done.

Однако если эту же строчку вызывает программа через вышеописанную функцию, то процедура занимает _гораздо_ больше времени. imDisk'овский экзешник долго висит на последней стадии "Notifying applications...", словно пытается уведомить родительский процесс. Если же функция вызывается через обычный ShellExecute и не отслеживается, то такой проблемы, похоже, нет.

Может ли кто подсказать, как этого избежать? Пока мысли идут в одну сторону - не отслеживать способами, что в той функции, а после запуска просто проверять в цикле со sleep'ом наличие окна с определенным хэндлом - но это смотрится глупо.

[mihali4]

В принципе, стандартный метод, описанный на десятке сайтов

Я знаю другие...
Попробуйте этот:

В приведённом ниже примере, не претендующем на панацею, используется запуск архиватора rar в отдельном процессе для архивирования/разархивирования целого каталога. После этого организуется цикл ожидания, до тех пор пока процесс не отработает. Обратите внимание, что используется альтернатива функции WaitForSingleObject(), собственная организация цикла. Хорошо это или плохо, решать вам.

Procedure CrProcess(FileName, S, Dir, WindowName: String);
Var SeInfo: TShellExecuteInfo;
   ExitCode: DWord;
Begin
 FillChar(SEInfo,SizeOf(SEInfo),0); 
 With SEInfo Do
  Begin
   cbSize:=SizeOf(TShellExecuteInfo);
   fmask:=SEE_MASK_NOCLOSEPROCESS;
   Wnd:=Application.Handle;
   lpFile:=PChar('"'+FileName+'"');
   lpParameters:=PChar(S);
   lpDirectory:=nil;
    { Можете использовать другие константы, если хотите, чтобы выполнение процесса было видно }
   nShow:=SW_HIDE;
  End; {With}
 IF ShellExecuteEx(@SEInfo) then
  Repeat
   Application.ProcessMessages;
   GetExitCodeProcess(SEInfo.hProcess,ExitCode);
  Until(FindWindow(nil,PChar(WindowName))<>0) or
       (ExitCode<>STILL_ACTIVE) or Application.Terminated else MessageDlg('Ошибка создания внешнего процесса. Код ошибки: '+SysErrorMessage(GetLastError),mtError,[mbAbort],0);
 CloseHandle(SEInfo.hProcess);
 IF FindWindow(nil,PChar(WindowName))<>0 then
  Begin
   SendMessage(FindWindow(nil,PChar(WindowName)),WM_CLOSE,0,0);
   While FindWindow(nil,PChar(WindowName))<>0 Do Application.ProcessMessages;
  End; {IF}
End;

Примеры использования:

// заархивировать
CrProcess('путь_к_архиваору_rar','a -r0 -m5 '+'имя_архива'+#32+'имя_каталога'+'*.*',TempPath,'(Сеанс завершен) - Rar');

// разархивировать
CrProcess('путь_к_архиваору_rar','x -y '+'имя_архива'+#32+'каталог_куда_разархивировать','(Сеанс завершен) - Rar');

Процедура написана исходя из совместимости со старыми ДОС процессами. ДОС программы не оставляют код завершения своего процесса по коду STILL_ACTIVE, а поэтому в таком случае запуск процесса "повиснет", т.е. будет постоянно "крутится" в цикле Repeat .. Until(). Для таких случаев преднозначена переменная WindowName. Когда ДОС задача завершается, появляется окно "(Сеанс завершён) - Имя_процесса". Используйте эту переменную, если вы запускаете ДОС программу, вписав при этом в эту переменную свою строку по аналогии. В этом случае цикл Repeat .. Until() оборвётся при наличии такого окна, т.е. когда процесс и завершится. До кучи ещё процедура закроет это окно, чтобы предотвратить проблему при многократных запусках.

[W0LF]

Лично мне более понравилься этот пример:

апуск программы с ожиданием её выполнения (мой способ, использован в этой программе)

procedure TFMain.ShellExecute_AndWait(FileName: string);
var
  exInfo: TShellExecuteInfo;
  Ph: DWORD;
begin
  FillChar(exInfo, SizeOf(exInfo), 0);
  with exInfo do
  begin
    cbSize := SizeOf(exInfo);
    fMask := SEE_MASK_NOCLOSEPROCESS or SEE_MASK_FLAG_DDEWAIT;
    Wnd := GetActiveWindow();
    ExInfo.lpVerb := 'open';
    lpFile := PChar(FileName);
    nShow := SW_SHOWNORMAL;
  end;
  if ShellExecuteEx(@exInfo) then
  begin
  Application.Minimize;
  Ph := exInfo.HProcess;
  end else
    Exit;
  while WaitForSingleObject(ExInfo.hProcess, 50) <> WAIT_OBJECT_0 do
    Application.ProcessMessages;
  CloseHandle(Ph);
Application.Restore;
end;

.................
Взято с: pblog.ru/lab