App launched with ShellExecuteEx not detected in EnumProcesses list

Question

After converting our code base to 64 bit (Delphi Alexandria 11.3) I noticed that a process launched by 'our' TTTLauncher component is not seen by our IsProcessRunning function using EnumProcesses. I do not suspect the detection part, but will include its code here too.

Launching the app:

var
   lLauncher : TTTLauncher;
   lEXE      : string;
begin
   lLauncher := TTTLauncher.Create(Application);
   lEXE := FPath+EdtProcess.Text;
   try
      lLauncher.FileName := lExe;
      lLauncher.Parameters := '-startprc';
      lLauncher.ShowMode := smNormal;
      lLauncher.WaitUntilFinished := False;
      lLauncher.RunAsAdministrator := True;
      lLauncher.Launch;

      Sleep(2500);

   finally
     FreeAndNil(lLauncher);
   end;
end;

This is the launcher (sorry for the long code):

unit TTLauncher;

interface

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

type
  TShowMode = ( smNormal, smMaximized, smMinimized, smHide );

const
  ShowWindowModes: array[ TShowMode ] of Integer =
    ( sw_Normal, sw_ShowMaximized, sw_ShowMinimized, sw_Hide );

type
  TTTLauncher = class;

  TTTLaunchThread = class( TThread )
  private
    FLauncher: TTTLauncher;
  protected
    procedure Execute; override;
  public
    constructor Create( ALauncher: TTTLauncher );
  end;

  TTTLaunchErrorEvent = procedure( Sender: TObject; ErrorCode: DWord ) of object;

  TTTWaitType = ( wtFullStop, wtProcessMessages );

  TTTEnumWinInfo = class(TObject)
    ProcessID : integer;
    WindowHandle : HWND;
  end;

  TTTLauncher = class( TComponent )
  private
    FHInstance: THandle;
    FAction: string;
    FFileName: string;
    FParameters: string;
    FShowMode: TShowMode;
    FStartDir: string;
    FTimeout: Integer;
    FWaitType: TTTWaitType;
    FWaitUntilFinished: Boolean;
    FOnFinished: TNotifyEvent;
    FOnTimeout: TNotifyEvent;
    FOnError: TTTLaunchErrorEvent;
    FExitCode: DWord;
    FLastErrorCode: DWord;
    FHProcess: THandle;
    FRunning: Boolean;
    FBackgroundThread: TTTLaunchThread;
    FProcessID: integer;
    FThreadID: integer;
    FHThread: THandle;
    FRunAsAdministrator : Boolean;
  protected
    procedure StartProcess; virtual;

    procedure Finished; dynamic;
    procedure DoTimeout; dynamic;
    procedure LaunchError; dynamic;

    procedure WaitForProcessAndProcessMsgs; virtual;
    procedure WaitForProcessFullStop; virtual;
    procedure WaitForProcessFromThread; virtual;
    procedure StartExecutable;
    procedure StartDataFile;
    procedure SetRunAsAdministrator(ARunAsAdministrator : boolean);

  public
    constructor Create( AOwner: TComponent ); override;
    destructor Destroy; override;

    procedure Launch; virtual;
    procedure StopProcess( ATimeOut : integer = 5000 );

    function GetErrorMsg( ErrorCode: DWord ): string;

    property ExitCode: DWord
      read FExitCode;

    property HProcess: THandle
      read FHProcess;

    property HThread: THandle
      read FHThread;

    property ProcessID: integer
      read FProcessID;

    property ThreadID: integer
      read FThreadID;

    property Running: Boolean
      read FRunning;
  published

    property Action: string
      read FAction
      write FAction;

    property FileName: string
      read FFileName
      write FFileName;

    property Parameters: string
      read FParameters
      write FParameters;

    property ShowMode: TShowMode
      read FShowMode
      write FShowMode
      default smNormal;

    property StartDir: string
      read FStartDir
      write FStartDir;

    property Timeout: Integer
      read FTimeout
      write FTimeout;

    property WaitType: TTTWaitType
      read FWaitType
      write FWaitType
      default wtFullStop;

    property WaitUntilFinished: Boolean
      read FWaitUntilFinished
      write FWaitUntilFinished
      default False;

    property OnFinished: TNotifyEvent
      read FOnFinished
      write FOnFinished;

    property OnError: TTTLaunchErrorEvent
      read FOnError
      write FOnError;

    property OnTimeout: TNotifyEvent
      read FOnTimeout
      write FOnTimeout;

    property RunAsAdministrator : Boolean
      read FRunAsAdministrator
      write SetRunAsAdministrator;
  end;


implementation

uses
  Registry,
  ShellApi;

constructor TTTLaunchThread.Create( ALauncher: TTTLauncher );
begin
  inherited Create( False );
  FLauncher := ALauncher;
  FreeOnTerminate := True;
end;

procedure TTTLaunchThread.Execute;
begin
  if FLauncher <> nil then
    FLauncher.StartProcess;
end;

constructor TTTLauncher.Create( AOwner: TComponent );
begin
  inherited;
  FShowMode := smNormal;
  FHInstance := 0;
  FAction := 'Open';
  FRunAsAdministrator := False;
  FHProcess := 0;
  FExitCode := 0;
  FTimeout := -1 {INFINITE};

  FRunning := False;
  FWaitType := wtFullStop;
  FWaitUntilFinished := False;
end;

destructor TTTLauncher.Destroy;
begin
  if FRunning and not FWaitUntilFinished and ( FBackgroundThread <> nil ) and not FBackgroundThread.Terminated then
  begin
    FBackgroundThread.Terminate;
    Sleep( 200 );
  end;

  inherited;
end;

procedure TTTLauncher.Finished;
begin
  if Assigned( FOnFinished ) then
    FOnFinished( Self );
end;

function TTTLauncher.GetErrorMsg( ErrorCode: DWord ): string;
begin
   Result := SysErrorMessage(ErrorCode);
end;

procedure TTTLauncher.LaunchError;
begin
  if Assigned( FOnError ) then
    FOnError( Self, FLastErrorCode );
end;

procedure TTTLauncher.DoTimeout;
begin
  if Assigned( FOnTimeout ) then
    FOnTimeout( Self );
end;

procedure TTTLauncher.WaitForProcessAndProcessMsgs;
begin
  repeat
    case MsgWaitForMultipleObjects( 1, FHProcess, False, Cardinal( FTimeout ),
                                    QS_POSTMESSAGE or QS_SENDMESSAGE or QS_ALLPOSTMESSAGE ) of
      WAIT_OBJECT_0:
      begin
        GetExitCodeProcess( FHProcess, FExitCode );
        Finished;
        Break;
      end;

      WAIT_OBJECT_0 + 1:
      begin
        Application.ProcessMessages;
      end;

      WAIT_TIMEOUT:
      begin
        DoTimeout;
        Break;
      end;
    end;

  until False;
end; // TTTLauncher.WaitForProcessAndProcessMsgs

procedure TTTLauncher.WaitForProcessFullStop;
begin
  case WaitForSingleObject( FHProcess, Cardinal( FTimeout ) ) of
    WAIT_FAILED:
    begin
      FLastErrorCode := GetLastError;
      LaunchError;
    end;

    WAIT_OBJECT_0:
    begin
      GetExitCodeProcess( FHProcess, FExitCode );
      Finished;
    end;

    WAIT_TIMEOUT:
      DoTimeout;
  end; { case }
end; // TTTLauncher.WaitForProcessFullStop

procedure TTTLauncher.WaitForProcessFromThread;
var
  Done: Boolean;
  TimeoutCount: Cardinal;
begin
  Done := False;
  TimeoutCount := 0;
  repeat
    case WaitForSingleObject( FHProcess, Cardinal( 100 ) ) of
      WAIT_FAILED:
      begin
        FLastErrorCode := GetLastError;
        FBackgroundThread.Synchronize( LaunchError );
        Done := True;
      end;

      WAIT_OBJECT_0:
      begin
        GetExitCodeProcess( FHProcess, FExitCode );
        FBackgroundThread.Synchronize( Finished );
        Done := True;
      end;

      WAIT_TIMEOUT:
      begin
        Inc( TimeoutCount, 100 );
        if TimeoutCount >= Cardinal( FTimeout ) then
        begin
          FBackgroundThread.Synchronize( DoTimeout );
          Done := True;
        end;
      end;
    end; { case }
  until Done or FBackgroundThread.Terminated;
end; // WaitForProcessFromThread

procedure TTTLauncher.StartDataFile;
var
  ShellInfo: TShellExecuteInfo;
begin
  FLastErrorCode := 0;
  FHInstance := 0;
  FHProcess := 0;
  FExitCode := 0;

  FillChar( ShellInfo, SizeOf( TShellExecuteInfo ), 0 );
  ShellInfo.cbSize := SizeOf( TShellExecuteInfo );
  ShellInfo.fMask := SEE_MASK_NOCLOSEPROCESS or SEE_MASK_FLAG_NO_UI or SEE_MASK_FLAG_DDEWAIT;
  ShellInfo.Wnd := HWnd_Desktop;
  ShellInfo.lpVerb := PChar( FAction );
  ShellInfo.lpFile := PChar( FFileName );
  ShellInfo.lpParameters := PChar( FParameters );
  ShellInfo.lpDirectory := PChar( FStartDir );
  ShellInfo.nShow := ShowWindowModes[ FShowMode ];

  if ShellExecuteEx( @ShellInfo ) then
  begin
    FHInstance := ShellInfo.hInstApp;
    FHProcess := ShellInfo.hProcess;
    FRunning := True;

    try
      if FWaitUntilFinished then
      begin
        if FWaitType = wtFullStop then
          WaitForProcessFullStop
        else
          WaitForProcessAndProcessMsgs;
      end
      else
        WaitForProcessFromThread;
    finally
      CloseHandle( FHProcess );
      FRunning := False;
    end;
  end
  else
  begin
    FLastErrorCode := ShellInfo.hInstApp;
    if FWaitUntilFinished then
      LaunchError
    else
      FBackgroundThread.Synchronize( LaunchError );
  end;
end; { StartDataFile }

procedure TTTLauncher.StartExecutable;
var
  StartupInfo: TStartupInfo;
  ProcessInfo: TProcessInformation;
  lCmd, lDir : string;
  lOK : Boolean;
begin
  FLastErrorCode := 0;
  FHInstance := 0;
  FHProcess := 0;
  FExitCode := 0;

  FillChar( StartupInfo, SizeOf( TStartupInfo ), 0 );
  StartupInfo.cb := SizeOf( TStartupInfo );
  StartupInfo.dwFlags := STARTF_USESHOWWINDOW;
  StartupInfo.wShowWindow := ShowWindowModes[ FShowMode ];

  FillChar( ProcessInfo, SizeOf( TProcessInformation ), 0 );

  lCmd := FFileName;
  if lCmd[1] <> '"' then lCmd := '"' + lCmd + '"';   // Quotes are needed http://stackoverflow.com/questions/265650/paths-and-createprocess

  if FParameters <> '' then lCmd := lCmd+' '+FParameters;

  lDir := FStartDir;

  if lDir='' then
     lOk := CreateProcess(nil,PChar(lCmd),nil,nil,FALSE,0,nil,nil,StartupInfo, ProcessInfo)
  else
     lOk := CreateProcess(nil,PChar(lCmd),nil,nil,FALSE,0,nil,PChar(FStartDir),StartupInfo, ProcessInfo);

  if lOk then
  begin
    FHInstance := 0;  //Niet bekend
    FHProcess  := ProcessInfo.hProcess;
    FHThread   := ProcessInfo.hThread;
    FProcessID := ProcessInfo.dwProcessId;
    FThreadID  := ProcessInfo.dwThreadId;
    FRunning := True;

    try
      if FWaitUntilFinished then
      begin
        if FWaitType = wtFullStop then
          WaitForProcessFullStop
        else
          WaitForProcessAndProcessMsgs;
      end
      else
        WaitForProcessFromThread;
    finally
      CloseHandle( FHThread );
      CloseHandle( FHProcess );
      FRunning := False;
    end;
  end
  else
  begin
    FLastErrorCode := GetLastError;

    if FWaitUntilFinished then
      LaunchError
    else
      FBackgroundThread.Synchronize( LaunchError );
  end;
end; // StartExecutable

procedure TTTLauncher.StartProcess;
var Ext: String;
begin
   Ext := lowercase(ExtractFileExt(FFileName));
   if ((Ext = '.exe') or (Ext = '.com')) and (FRunAsAdministrator = False) then
   begin
      StartExecutable;
   end
   else
   begin
      StartDataFile;
   end;
end; // StartProcess

procedure TTTLauncher.Launch;
begin
  if FRunning or ( FFileName = '' ) then
    Exit;

  if FWaitUntilFinished then
    StartProcess
  else
  begin
    FBackgroundThread := TTTLaunchThread.Create( Self );
    repeat
      Sleep( 10 );
    until FRunning or ( FLastErrorCode <> 0 );
  end;
end;

procedure TTTLauncher.StopProcess( ATimeOut : integer = 5000 );
var
   lTijd : integer;
begin
   // Try to close with quit message
   if FRunning then
   begin
      PostThreadMessage(FThreadID,WM_QUIT, 0, 0);
      Sleep(10);
      Application.ProcessMessages;

      // Wait for process to stop or timeout
      lTijd := 0;
      while FRunning and (lTijd<ATimeOut) do
      begin
         Sleep(10);
         Inc(lTijd,10);
         Application.ProcessMessages;
      end;
   end;

   // Kill process if still running
   if FRunning then
   begin
      TerminateProcess(HProcess,1);
      Sleep(200); // Give it some time to clean up
      Application.ProcessMessages;
   end;

   // Close background thread
   if FRunning and not FWaitUntilFinished and ( FBackgroundThread <> nil ) and not FBackgroundThread.Terminated then
   begin
      FBackgroundThread.Terminate;
      Sleep(200); // Some time to clean up
   end;
end;

Function EnumWindowsProc (Wnd: HWND; AEnumInfo : TTTEnumWinInfo): BOOL; stdcall;
var
  lWndProcessId : integer;
begin
   Result := True;

   GetWindowThreadProcessId(Wnd, @lWndProcessId);

   // Proces ID match? => found (1e window is main window)
   if (lWndProcessId = AEnumInfo.ProcessID) then
   begin
      AEnumInfo.WindowHandle := Wnd;
      Result := False;
   end;
end;

function IsUACEnabled: Boolean;
var
  Reg: TRegistry;
begin
  Result := CheckWin32Version(6, 0);
  if Result then
  begin
    Reg := TRegistry.Create(KEY_READ);
    try
      Reg.RootKey := HKEY_LOCAL_MACHINE;
      if Reg.OpenKey('\Software\Microsoft\Windows\CurrentVersion\Policies\System', False) then
        if Reg.ValueExists('EnableLUA') then
          Result := (Reg.ReadInteger('EnableLUA') <> 0)
        else
          Result := False
      else
        Result := False;
    finally
      FreeAndNil(Reg);
    end;
  end;
end;

procedure TTTLauncher.SetRunAsAdministrator(ARunAsAdministrator : boolean);
begin
   FRunAsAdministrator := ARunAsAdministrator;

   if (FRunAsAdministrator = True) and (IsUACEnabled = False) then
   begin
      FRunAsAdministrator := False;
   end;

   if (FRunAsAdministrator = True) then
   begin
      FAction := 'runas';
   end
   else
   begin
      FAction := 'Open';
   end;
end;

end.

Detecting the app fails with IsProcessRunning(FPath + EdtProcess.Text,true) or IsProcessRunning(FPath + EdtProcess.Text,false):

type
   TQueryFullProcessImageNameW = function(AProcess: THANDLE; AFlags: DWORD; AFileName: PWideChar; var ASize: DWORD): BOOL; stdcall;
const
   QueryFullProcessImageNameW: TQueryFullProcessImageNameW = nil;
   PROCESS_QUERY_LIMITED_INFORMATION = $1000;
var
   Kernel32Lib: HMODULE;

function IsProcessRunning(AFileName: string; AIncludePath : Boolean = False): Boolean;
var
  PIDList: array[0..1023] of DWORD;
  i: integer;
  ListCount: cardinal;
  hProcess: THandle;
  lFileName : string;
  lStrModuleName: String;
  Len : DWORD;
begin
  Result:= False;

  if not AIncludePath then
     AFileName := ExtractFileName(AFileName);

  // PSAPI.DLL required
  if not EnumProcesses(@PIDList, sizeof(PIDList), ListCount) then Exit;

  ListCount:= ListCount div sizeof(THandle);

  FrmIsProcRunning.MmoProcesses.Lines.Add('Process count: ' + IntToStr(ListCount));
  FrmIsProcRunning.MmoProcesses.Lines.Add('');

  for i := 0 to ListCount-1 do
  begin

    if assigned(QueryFullProcessImageNameW) then
    begin
       hProcess:= OpenProcess(PROCESS_QUERY_LIMITED_INFORMATION, false, PIDList[i]);

       try
          if hProcess <> 0 then
          begin
             Len := MAX_PATH;
             SetLength(lStrModuleName, Len-1);
             if QueryFullProcessImageNameW( hProcess, 0, PWideChar(lStrModuleName), Len) then
             // Niet meer @Len, maar Len, omdat-ie nu als var parameter gedefinieerd is
             begin
                SetLength(lStrModuleName, Len);
                lFileName := lStrModuleName;
                FrmIsProcRunning.MmoProcesses.Lines.Add(lFilename);
             end;
          end;
       finally
         CloseHandle(hProcess);
       end;
    end;

    if (not AIncludePath) then
       lFileName := ExtractFileName(lFileName);

    if CompareText(lFileName, AFileName) = 0 then
    begin
      Result := true;
      Exit;
    end;
  end;
end;

with initialization code:

FPath := ExtractFilePath(ParamStr(0));
Kernel32Lib := GetModuleHandle(kernel32);
QueryFullProcessImageNameW := GetProcAddress(Kernel32Lib, 'QueryFullProcessImageNameW');

I've been looking at the TTTLauncher but fail to see what would no longer work under 64-bit. Any suggestions?

Notes:

All apps are 64 bit and in the same folder (on D:) that I have full access to
I tested running the launching app As Invoker, Highest avaialable, Requires Administrator
I tested running the launching app from within or outside the IDE
I'm surprised that the TTTLauncher.StartProcess calls StartDataFile (not StartExecutable) because FRunAsAdministrator is true. Why would that be? (Old code, not mine)
Windows 10

So what does `FPath+EdtProcess.Text` contain? Change your Q to something that is reproducible, as in: everyone should get the same result. — AmigoJack, Jun 09 '23 at 16:35
FPath = ExtractFilePath(ParamStr(0)) and the executable is TTServer.exe — Jan Doggen, Jun 10 '23 at 14:55
And you cannot imagine that it can make a difference on how `ParamStr( 0 )` actually looks like? **ARE YOU SURE** the path is empty, because you just comment "_TTServer.exe_" without any? — AmigoJack, Jun 10 '23 at 18:35
I don't get this, or the downvotes either. What am I missing? This test app does not work in any folder I test. *All apps are 64 bit and in the same folder* — Jan Doggen, Jun 11 '23 at 10:39
The more complex your sample code is, the more you have to focus on getting it 1:1 reproduciable for others. Not telling the exact command line (more likely it is `C:\Program Files\Anything\TTServer.exe` with a proper path because of `FPath` and proper casing) is leaving out a big detail. And since none of us has this EXE: have you tried it with `C:\Windows\System32\calc.exe`, too? That would be a great common denominator for all of us. — AmigoJack, Jun 11 '23 at 13:09

Jan Doggen · Answer 1 · 2023-06-21T10:06:54.080

Wow, the issue was that EnumProcesses did not 'detect' the PID of the running process. But look at this:

var
  PIDList: array[0..1023] of DWORD;
  
begin
  if not EnumProcesses(@PIDList, sizeof(PIDList), ListCount) then Exit;
  ListCount:= ListCount div sizeof(THandle);   <=== !!!

sizeof(THandle) = 8, sizeof(DWORD) = 4 (This is 64 bit)

I changed the code to

ListCount := ListCount div sizeof(DWORD);

And this gives me a ListCount of approx 150 (earlier: 73), which is more in line with what I see in Task Manager. The PID is then found.

^{* The 32-bit code used THandle, and I changed that to DWORD when going 64-bit, but forgot the ListCount calculation}

App launched with ShellExecuteEx not detected in EnumProcesses list

1 Answers1