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
callsStartDataFile
(notStartExecutable
) becauseFRunAsAdministrator
is true. Why would that be? (Old code, not mine) - Windows 10
FPath+EdtProcess.Text
contain? Change your Q to something that is reproducible, as in: everyone should get the same result.ParamStr( 0 )
actually looks like? ARE YOU SURE the path is empty, because you just comment "TTServer.exe" without any?C:\Program Files\Anything\TTServer.exe
with a proper path because ofFPath
and proper casing) is leaving out a big detail. And since none of us has this EXE: have you tried it withC:\Windows\System32\calc.exe
, too? That would be a great common denominator for all of us.