I'm trying to get the process count starting from an executable full file name.
Here is my code:
function GetPathFromPID(const PID: cardinal): string;
var
hProcess: THandle;
path: array[0..MAX_PATH - 1] of char;
begin
hProcess := OpenProcess(PROCESS_QUERY_INFORMATION or PROCESS_VM_READ, false, PID);
if hProcess <> 0 then
try
if GetModuleFileNameEx(hProcess, 0, path, MAX_PATH) = 0 then
RaiseLastOSError;
result := path;
finally
CloseHandle(hProcess)
end
else
RaiseLastOSError;
end;
function ProcessCount(const AFullFileName: string): Integer;
var
ContinueLoop: boolean;
FSnapshotHandle: THandle;
FProcessEntry32: TProcessEntry32;
begin
FSnapshotHandle := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0);
FProcessEntry32.dwSize := SizeOf(FProcessEntry32);
ContinueLoop := Process32First(FSnapshotHandle, FProcessEntry32);
Result := 0;
while(ContinueLoop) do
begin
if ((UpperCase(GetPathFromPID(FProcessEntry32.th32ProcessID)) = UpperCase(AFullFileName)))
then Result := Result + 1;
ContinueLoop := Process32Next(FSnapshotHandle, FProcessEntry32);
end;
CloseHandle(FSnapshotHandle);
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
Self.Caption := IntToStr(ProcessCount(Application.ExeName));
end;
GetPathFromPID function has been taken from here (Andreas Rejbrand's answer).
Running the application, I got EOSError exception ('System Error. Code: 87.'). As documentation says:
ERROR_INVALID_PARAMETER
87 (0x57)
The parameter is incorrect.
The exception is raised from GetPathFromPID function, because the hProcess <> 0 condition fails and RaiseLastOSError is executed.
Debugging I've noticed that 0 is passed to GetPathFromPID function as PID parameter but I don't understand what's wrong in my code.
OpenProcess returns ERROR_INVALID_PARAMETER when you give it a PID of zero.
But also you may get ERROR_ACCESS_DENIED if the process that you pass it to OpenProcess through GetPathFromPID function requires elevation.
Use this instated to make sure that you'r passing process have the same name only.
while (ContinueLoop) do
begin
if SameText(ExtractFileName(AFullFileName), FProcessEntry32.szExeFile) then
if ((UpperCase(GetPathFromPID(FProcessEntry32.th32ProcessID)) = UpperCase(AFullFileName)))
....
end;
It is possible that FProcessEntry32.th32ProcessID entry will be 0.
For example for the first process of [System Process] (check FProcessEntry32.szExeFile) has a PID of 0. I'm pretty sure this is the only entry with th32ProcessID == 0. See "System Idle Process".
So simply check that FProcessEntry32.th32ProcessID <> 0 before you pass it on to GetPathFromPID.
Related
In a 32-bit VCL application on Windows 10 in Delphi 11 Alexandria, I try to detect whether a specific Delphi version is currently running. So I used the Winapi.TlHelp32.CreateToolhelp32Snapshot function to search for "bds.exe":
function ProcessExists(exeFileName: string): Boolean;
var
ContinueLoop: Winapi.Windows.BOOL;
FSnapshotHandle: Winapi.Windows.THandle;
FProcessEntry32: Winapi.TlHelp32.TProcessEntry32;
begin
FSnapshotHandle := Winapi.TlHelp32.CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0);
FProcessEntry32.dwSize := System.SizeOf(FProcessEntry32);
ContinueLoop := Winapi.TlHelp32.Process32First(FSnapshotHandle, FProcessEntry32);
Result := False;
while Integer(ContinueLoop) <> 0 do
begin
if SameText(ExtractFileName(FProcessEntry32.szExeFile), ExeFileName) or SameText(FProcessEntry32.szExeFile, ExeFileName) then
begin
Result := True;
CodeSite.Send('ProcessExists: FProcessEntry32.szExeFile', FProcessEntry32.szExeFile);
BREAK;
end;
ContinueLoop := Process32Next(FSnapshotHandle, FProcessEntry32);
end;
Winapi.Windows.CloseHandle(FSnapshotHandle);
end;
...
CodeSite.Send('ProcessExists(ThisBdsExe)', ProcessExists('bds.exe'));
Unfortunately, FProcessEntry32.szExeFile returns only the FILENAME without the PATH information. So I get only the information whether Delphi is running, but NOT whether a specific Delphi version is running!
Is there any way to get the PATH information from the FProcessEntry32 structure?
Of course, I know the paths of each bds.exe that exists on my computer. But this does not work:
CodeSite.Send('ProcessExists(Delphi 11 bds.exe path)', ProcessExists('C:\Program Files (x86)\Embarcadero\Studio\22.0\bin\bds.exe'));
The API help for PROCESSENTRY32's szExeFile entry:
szExeFile
The name of the executable file for the process. To retrieve the full
path to the executable file, call the Module32First function and check
the szExePath member of the MODULEENTRY32 structure that is returned.
However, if the calling process is a 32-bit process, you must call the
QueryFullProcessImageName function to retrieve the full path of the
executable file for a 64-bit process.
So you need to make a Module32First call and currently at least BDS is a 32bit process so you don't need to use QueryFullProcessImageName even if your app is 32bit.
GetModuleFileNameEx worked for me:
function GetPathFromPID(const PID: cardinal): string;
var
hProcess: THandle;
path: array[0..MAX_PATH - 1] of char;
begin
hProcess := OpenProcess(PROCESS_QUERY_INFORMATION or PROCESS_VM_READ, false, PID);
if hProcess <> 0 then
try
if GetModuleFileNameEx(hProcess, 0, path, MAX_PATH) = 0 then
RaiseLastOSError;
result := path;
finally
CloseHandle(hProcess)
end
else
RaiseLastOSError;
end;
function ProcessExists(exeFileName: string): Boolean;
var
ContinueLoop: Winapi.Windows.BOOL;
FSnapshotHandle: Winapi.Windows.THandle;
FProcessEntry32: Winapi.TlHelp32.TProcessEntry32;
begin
FSnapshotHandle := Winapi.TlHelp32.CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0);
FProcessEntry32.dwSize := System.SizeOf(FProcessEntry32);
ContinueLoop := Winapi.TlHelp32.Process32First(FSnapshotHandle, FProcessEntry32);
Result := False;
var ThisExeName := ExtractFileName(exeFileName);
while Integer(ContinueLoop) <> 0 do
begin
if SameText(ExtractFileName(FProcessEntry32.szExeFile), ThisExeName) or SameText(FProcessEntry32.szExeFile, ThisExeName) then
begin
var ThisBdsExePath := GetPathFromPID(FProcessEntry32.th32ProcessID);
Result := SameText(exeFileName, ThisBdsExePath);
if Result then BREAK;
end;
ContinueLoop := Process32Next(FSnapshotHandle, FProcessEntry32);
end;
Winapi.Windows.CloseHandle(FSnapshotHandle);
end;
Following code
function Run(exePath, cmdLine, currDir: string): Boolean;
var
si: TStartupInfo;
pinf: TProcessInformation;
hStdOut: THandle;
sa: TSecurityAttributes;
lastErr: LongWord;
begin
sa.nLength := SizeOf(TSecurityAttributes);
sa.bInheritHandle := True;
sa.lpSecurityDescriptor := nil;
si := default(TStartupInfo);
si.cb := SizeOf(si);
si.dwFlags := si.dwFlags; // or STARTF_USESTDHANDLES;
SetLastError(0);
Result := Createprocess(PWideChar(exePath), PWideChar(cmdLine), nil, nil,
True, 0 {CREATE_NEW_CONSOLE}, nil, PWideChar(currDir), si, pinf);
if Result then begin
WaitForSingleObject(pinf.hProcess, INFINITE);
lastErr := GetLastError(); // Here error 1812
if lastErr <> 0 then ShowError(lastErr);
CloseHandle(pinf.hProcess);
CloseHandle(pinf.hThread);
end
else begin
lastErr := GetLastError();
if lastErr <> 0 then ShowError(lastErr);
end;
end;
produces error 1812 (The specified image file did not contain a resource section) on various executables (git, cgrc, dcc32).
What is it and how to eliminate it?
P.S. Here is an extracted piece of code I was wondering about:
SetLastError(0);
ShowError(GetLastError()); // Here the error code is 0
Result := Createprocess(PWideChar(exePath), PWideChar(cmdLine), nil, nil, False, 0, nil, PWideChar(currDir), si, pinf);
ShowError(GetLastError()); // Here error 1812
My logic was as follows: If before of CreateProcess call the last error code is 0, and after is not 0, then it is definitely CreateProcess who set the value. And why to set an error code if no error happened?
This logic seems to be false and even if the function succeeds, last error code can be set.
Your error handling code is broken. Your function should look like this:
function Run(exePath, cmdLine, currDir: string): Boolean;
var
si: TStartupInfo;
pinf: TProcessInformation;
hStdOut: THandle;
sa: TSecurityAttributes;
waitResult: DWORD;
lastErr: LongWord;
begin
sa.nLength := SizeOf(TSecurityAttributes);
sa.bInheritHandle := True;
sa.lpSecurityDescriptor := nil;
si := default(TStartupInfo);
si.cb := SizeOf(si);
si.dwFlags := si.dwFlags; // or STARTF_USESTDHANDLES;
UniqueString(cmdLine);
Result := CreateProcess(PWideChar(exePath), PWideChar(cmdLine), nil, nil,
True, 0 {CREATE_NEW_CONSOLE}, nil, PWideChar(currDir), si, pinf);
if Result then begin
waitResult := WaitForSingleObject(pinf.hProcess, INFINITE);
if waitResult = WAIT_FAILED then begin
lastErr := GetLastError();
if lastErr <> 0 then ShowError(lastErr);
end else begin
Assert(waitResult = WAIT_OBJECT_0);
end;
CloseHandle(pinf.hProcess);
CloseHandle(pinf.hThread);
end
else begin
lastErr := GetLastError();
if lastErr <> 0 then ShowError(lastErr);
end;
end;
Notes:
The second argument to CreateProcess must be a writeable string. Hence the call to UniqueString.
As documented in WaitForSingleObject, failure is indicated by the return value. You should only call GetLastError in case the return value indicates failure.
I removed the call to SetLastError(0) which is needless.
If ShowError raises exceptions then this function will leak handles.
I expect that what was happening was that CreateProcess was succeeding, but not setting the last error to zero, which it has no obligation to do. Remember that success or failure is indicated by the return value, not the error code. Then WaitForSingleObject was also succeeding, and not setting the error code to zero, again which it has no obligation to do. Or perhaps it was WaitForSingleObject that was setting the error code to a non-zero value. In any case, which function did this is moot. Once you fix the error checking code, you won't ever have cause to look at this meaningless error code.
Finally, are you quite sure that you want the child process to inherit handles?
I have created this function to get the path of various network processes, like svchost, Firefox, etc. Here is the code:
function GetProcessPath(var pId:Integer):String;
var
Handle: THandle;
begin
Result := '';
try
Handle := OpenProcess(PROCESS_QUERY_INFORMATION or PROCESS_VM_READ, False, pID);
if Handle <> 0 then
begin
try
SetLength(Result, MAX_PATH);
if GetModuleFileNameEx(Handle, 0, PChar(Result), MAX_PATH) > 0 then
SetLength(Result, StrLen(PChar(Result)))
else
Result := '';
finally
CloseHandle(Handle);
end;
end;
except
on E:Exception do
ShowMessage(E.ClassName + ':' + E.Message);
end;
end;
My problem is that I do not get the path of all the processes. It works fine for getting the path of Firefox, and other similar user level processes. But for processes like alg, Svchost, I cannot get the path by this method. My guess is I must use some different API. How can I fix this problem?
I am using Windows XP, 32 bits.
You need to set debug privileges. Here is how it is done:
function NTSetPrivilege(sPrivilege: string; bEnabled: Boolean): Boolean;
var
hToken: THandle;
TokenPriv: TOKEN_PRIVILEGES;
PrevTokenPriv: TOKEN_PRIVILEGES;
ReturnLength: Cardinal;
begin
Result := True;
// Only for Windows NT/2000/XP and later.
if not (Win32Platform = VER_PLATFORM_WIN32_NT) then Exit;
Result := False;
// Obtain the processes token
if OpenProcessToken(GetCurrentProcess(),
TOKEN_ADJUST_PRIVILEGES or TOKEN_QUERY, hToken) then
begin
try
// Get the locally unique identifier (LUID) .
if LookupPrivilegeValue(nil, PChar(sPrivilege),
TokenPriv.Privileges[0].Luid) then
begin
TokenPriv.PrivilegeCount := 1; // One privilege to set
case bEnabled of
True: TokenPriv.Privileges[0].Attributes := SE_PRIVILEGE_ENABLED;
False: TokenPriv.Privileges[0].Attributes := 0;
end;
ReturnLength := 0; // Replaces a var parameter
PrevTokenPriv := TokenPriv;
// Enable or disable the privilege
AdjustTokenPrivileges(hToken, False, TokenPriv, SizeOf(PrevTokenPriv),
PrevTokenPriv, ReturnLength);
end;
finally
CloseHandle(hToken);
end;
end;
end;
NtSetPrivilege('SeDebugPrivilege', TRUE); // Call this on form create
I have a hopefully quick question: Is it possible to delay execution of ShellExecute a little bit?
I have an application with autoupdater. After it downloads all necessary files etc, it renames current files to *.OLD and the new as the previous. Simple enough. But then I need to delete those .OLD files. This 'cleanup' procedure is executed on MainForm.OnActivate (with a check if it is the first activate proc). But this apparently happens too fast (I get False from DeleteFile). This is the procedure:
procedure TUpdateForm.OKBtnClick(Sender: TObject);
const SHELL = 'ping 127.0.0.1 -n 2';
begin
ShellExecute(0,'open',pchar(SHELL+#13+Application.ExeName),nil,nil,SW_SHOWNORMAL);
Application.Terminate;
end;
This procedure is supposed to restart the application. I am certain that the deleting problem is caused by the quick start of the second application, because if I restart it myself, giving it a little time, the files get deleted normally.
tl;dr version: I need to call ShellExecute() which waits a bit (0.1 sec or so) and THEN executes the command.
Note
I tried using the -ping command to try to delay it, but it didn't work.
Thank you very much in advance
Edit: Rephrased
I need this to happen || First app closes; Wait 100 ms; second app opens ||. I need to call ShellExecute first, then wait until the calling application closes itself completely, then execute the shell (i.e. open second application)
You're doing an autopatcher right ?
I've had the same problem and this is how I bypassed it :
You run second app with argument "--delay" or something like that.
Second app handles argument "--delay" and sleeps for 100 ms, then continues running normally.
This routine is some utils code in our game engine. It can run an executable and optionally wait for it to exit. It will return its exit code:
function TSvUtils.FileExecute(ahWnd: Cardinal; const aFileName, aParams, aStartDir: string; aShowCmd: Integer; aWait: Boolean): Integer;
var
Info: TShellExecuteInfo;
ExitCode: DWORD;
begin
Result := -1;
FillChar(Info, SizeOf(Info), 0);
Info.cbSize := SizeOf(TShellExecuteInfo);
with Info do begin
fMask := SEE_MASK_NOCLOSEPROCESS;
Wnd := ahWnd;
lpFile := PChar(aFileName);
lpParameters := PChar(aParams);
lpDirectory := PChar(aStartDir);
nShow := aShowCmd;
end;
if ShellExecuteEx(#Info) then
begin
if aWait then
begin
repeat
Sleep(1);
Application.ProcessMessages;
GetExitCodeProcess(Info.hProcess, ExitCode);
until (ExitCode <> STILL_ACTIVE) or Application.Terminated;
CloseHandle(Info.hProcess);
Result := ExitCode;
end;
end
end;
Here is some code that can check to see if a process exists. So... current app calls the updater and terminates. The updater can check to see if old app has terminated and do it's thing (rename, update, delete, etc):
function TSvUtils.ProcessExists(const aExeFileName: string; aBringToForgound: Boolean=False): Boolean;
var
ContinueLoop: BOOL;
FSnapshotHandle: THandle;
FProcessEntry32: TProcessEntry32;
begin
FSnapshotHandle := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0);
FProcessEntry32.dwSize := SizeOf(FProcessEntry32);
ContinueLoop := Process32First(FSnapshotHandle, FProcessEntry32);
Result := False;
while Integer(ContinueLoop) <> 0 do
begin
if ((UpperCase(ExtractFileName(FProcessEntry32.szExeFile)) =
UpperCase(aExeFileName)) or (UpperCase(FProcessEntry32.szExeFile) =
UpperCase(aExeFileName))) then
begin
if aBringToForgound then
EnumWindows(#BringToForgroundEnumProcess, FProcessEntry32.th32ProcessID);
Result := True;
end;
ContinueLoop := Process32Next(FSnapshotHandle, FProcessEntry32);
end;
CloseHandle(FSnapshotHandle);
end;
If you can use CreateProcess instead of ShellExecute, you can wait on the process handle. The process handle is signalled when the application exits. For example:
function ExecAndWait(APath: string; var VProcessResult: cardinal): boolean;
var
LWaitResult : integer;
LStartupInfo: TStartupInfo;
LProcessInfo: TProcessInformation;
begin
Result := False;
FillChar(LStartupInfo, SizeOf(TStartupInfo), 0);
with LStartupInfo do
begin
cb := SizeOf(TStartupInfo);
dwFlags := STARTF_USESHOWWINDOW or STARTF_FORCEONFEEDBACK;
wShowWindow := SW_SHOWDEFAULT;
end;
if CreateProcess(nil, PChar(APath), nil, nil,
False, NORMAL_PRIORITY_CLASS,
nil, nil, LStartupInfo, LProcessInfo) then
begin
repeat
LWaitResult := WaitForSingleObject(LProcessInfo.hProcess, 500);
// do something, like update a GUI or call Application.ProcessMessages
until LWaitResult <> WAIT_TIMEOUT;
result := LWaitResult = WAIT_OBJECT_0;
GetExitCodeProcess(LProcessInfo.hProcess, VProcessResult);
CloseHandle(LProcessInfo.hProcess);
CloseHandle(LProcessInfo.hThread);
end;
end;
After ExecAndWait returns, then you can sleep for 100ms if you need to.
N#
Is there support in the Delphi XE VCL for ensuring only a single instance of an application is running?
In the past, I've used library code to control a Mutex which has always seemed complicated. As I'm starting a new project in Delphi XE, I wonder if I need to dig up that old code, or if there is support built into XE already? Or is there another easy to apply code that is nice and modern?
You create a named Mutex when you start the application. Check GetLastError to see if an other instance is already running.
Put this code right after "begin" in your DPR file. Replace the GUID with one of your own. When I need a text constant that's unlikely to be used for anything else, I usually just hit Ctrl+G to get a GUID!
if CreateMutex(nil, True, '6EACD0BF-F3E0-44D9-91E7-47467B5A2B6A') = 0 then
RaiseLastOSError;
if GetLastError = ERROR_ALREADY_EXISTS then
Exit;
It might look like the code is leaking an handle because it's not saving the return of CreateMutex. It's not. Windows will automatically release the handle when our application is terminated, and that's absolutely fine with us.
I use JCL to do this:
program MyProgram;
uses
JclAppInst;
begin
JclAppInstances.CheckSingleInstance; // Added instance checking
Application.Initialize;
Application.CreateForm(TMainForm, MainForm);
Application.Run;
end.
Documentation for this, and the notification scheme, is at the JCL Wiki.
I use this, works in XE2 through to Alexandria, has the benefit of being able to bring the currently running instance to the front.
Those that say it shouldn't do that, well, given the last thing the user did was to try launch the app, bringing a currently running instance to the front makes sense
unit CheckPrevious;
interface
uses
Windows, SysUtils, WinSock;
function RestoreIfRunning(const AppHandle : THandle; MaxInstances : integer = 1) : boolean;
implementation
type
PInstanceInfo = ^TInstanceInfo;
TInstanceInfo = packed record
PreviousHandle : THandle;
RunCounter : integer;
end;
var
MappingHandle: THandle;
InstanceInfo: PInstanceInfo;
MappingName : string;
RemoveMe : boolean = True;
function RestoreIfRunning(const AppHandle : THandle; MaxInstances : integer = 1) : boolean;
begin
Result := True;
MappingName := StringReplace(ParamStr(0),'\','',[rfReplaceAll, rfIgnoreCase]);
MappingHandle := CreateFileMapping($FFFFFFFF,nil,PAGE_READWRITE,0,SizeOf(TInstanceInfo),PChar(MappingName));
if MappingHandle = 0 then
RaiseLastOSError
else
begin
if GetLastError <> ERROR_ALREADY_EXISTS then
begin
InstanceInfo := MapViewOfFile(MappingHandle,FILE_MAP_ALL_ACCESS,0,0,SizeOf(TInstanceInfo));
InstanceInfo^.PreviousHandle := AppHandle;
InstanceInfo^.RunCounter := 1;
Result := False;
end
else //already runing
begin
MappingHandle := OpenFileMapping(FILE_MAP_ALL_ACCESS, False, PChar(MappingName));
if MappingHandle <> 0 then
begin
InstanceInfo := MapViewOfFile(MappingHandle,FILE_MAP_ALL_ACCESS,0,0,SizeOf(TInstanceInfo));
if InstanceInfo^.RunCounter >= MaxInstances then
begin
RemoveMe := False;
if IsIconic(InstanceInfo^.PreviousHandle) then
ShowWindow(InstanceInfo^.PreviousHandle, SW_RESTORE);
SetForegroundWindow(InstanceInfo^.PreviousHandle);
end
else
begin
InstanceInfo^.PreviousHandle := AppHandle;
InstanceInfo^.RunCounter := 1 + InstanceInfo^.RunCounter;
Result := False;
end
end;
end;
end;
end;
initialization
finalization
//remove one instance
if RemoveMe then
begin
MappingHandle := OpenFileMapping(FILE_MAP_ALL_ACCESS, False, PChar(MappingName));
if MappingHandle <> 0 then
begin
InstanceInfo := MapViewOfFile(MappingHandle, FILE_MAP_ALL_ACCESS, 0, 0, SizeOf(TInstanceInfo));
InstanceInfo^.RunCounter := -1 + InstanceInfo^.RunCounter;
end
else
RaiseLastOSError;
end;
if Assigned(InstanceInfo) then
UnmapViewOfFile(InstanceInfo);
if MappingHandle <> 0 then
CloseHandle(MappingHandle);
end.
In your project DPR, add the CheckPrevious unit to the uses, then just after begin put the following
if RestoreIfRunning(Application.Handle, 1) then
Exit;
I have no idea of where this code originated, otherwise I would gladly credit the author. (A search of RestoreIfRunning may suggest it was from Zarko Gajic)
This is how i do it.
closeProc(extractfilename(paramstr(0)));
function TForm1.closeProc(pname : string): integer;
const
PROCESS_TERMINATE = $0001;
var
ContinueLoop: BOOL;
FSnapshotHandle: THandle;
FProcessEntry32: TProcessEntry32;
i : integer;
pname2 : string;
begin
try
Result := 0;
i := 0;
FSnapshotHandle := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0);
FProcessEntry32.dwSize := SizeOf(FProcessEntry32);
ContinueLoop := Process32First(FSnapshotHandle, FProcessEntry32);
while Integer(ContinueLoop) <> 0 do
begin
pname2 := trim(UpperCase(ExtractFileName(FProcessEntry32.szExeFile)));
if ( pname2 = uppercase(pname)) then
if FProcessEntry32.th32ProcessID <> GetCurrentProcessId then
begin
Result := Integer(TerminateProcess(OpenProcess(PROCESS_TERMINATE, BOOL(0), FProcessEntry32.th32ProcessID), 0));
inc(i);
end;
ContinueLoop := Process32Next(FSnapshotHandle, FProcessEntry32);
if i > 50 then
break;
end;
CloseHandle(FSnapshotHandle);
except
end;
end;