How can we determine a program is already running in either in the current user or other user in delphi

Question

I am trying to determine whether a certain process is running under the current user or under another user on the same pc. I've applied the following code and it works well as it program can determine the process from the task manager if that the certain process is running under the current user. Is there any ways to allow me to determine the running process if it is running under another user?

function ProcessExist(const APName: string; out PIDObtained: Cardinal): Boolean;
var
  isFound: boolean;
  AHandle, AhProcess: THandle;
  ProcessEntry32: TProcessEntry32;
  APath: array [0 .. MAX_PATH] of char;
begin
  AHandle := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0);
  try
    ProcessEntry32.dwSize := SizeOf(ProcessEntry32);
    isFound := Process32First(AHandle, ProcessEntry32);
    Result := False;
    while Integer(isFound) <> 0 do
    begin
      AhProcess := OpenProcess(PROCESS_QUERY_INFORMATION or PROCESS_VM_READ, false, ProcessEntry32.th32ProcessID);

      if (UpperCase(StrPas(APath)) = UpperCase(APName)) or (UpperCase(ExtractFileName(ProcessEntry32.szExeFile)) = UpperCase(APname)) or
      (UpperCase(ProcessEntry32.szExeFile) = UpperCase(APName)) then begin
        GetModuleFileNameEx(AhProcess, 0, @APath[0], SizeOf(APath));
        if ContainsStr(StrPas(APath), TPath.GetHomePath() + TPath.DirectorySeparatorChar) then begin
          PIDObtained := ProcessEntry32.th32ProcessID;
          Result := true;
          break;
        end;
      end;
      isFound := Process32Next(AHandle, ProcessEntry32);
      CloseHandle(AhProcess);
    end;
  finally
    CloseHandle(AHandle);
  end;
end;

Answer 1

Mutexes

Assuming the operational system is Windows, there are the Mutex objects. Mutexes are system resources. System resource means resource available for all processes in the storing area of the system. Any process can create and close (release) a mutex. Once a process created a mutex, another process can access it but unable to create a new instance until the existing one not closed.

Startup Mutex handling

So one solution to your problem is to check the existence of an unique named mutex on startup and react according to the answer:

• the mutex exists : notify the user and exit the program.
• the mutex does not exist : register the mutex and keep the process running

You can include some attributes to the mutex name:

• program path : the instances launched from different folders won't consider the same
• version number : the different versions of the app won't consider the same
• another environment/app characteristics (Windows user name) to make running instances different

Solution:

MyApp.dpr:

program Project3;

uses
  Vcl.Forms,
  Unit1 in 'Unit1.pas' {TForm1},
  MutexUtility in 'MutexUtility.pas',
  Dialogs;

{$R *.res}

var
  hMutex : THandle;
  mutexName : string;

begin
  mutexName := TMutexUtility.initMutexName;
  if ( TMutexUtility.tryCreateMutex( mutexName, hMutex ) ) then
    try
      Application.Initialize;
      Application.MainFormOnTaskbar := True;
      Application.CreateForm(TForm1, Form1);
      Application.Run;
    finally
      TMutexUtility.releaseMutex( hMutex );
    end
  else
    showMessage( 'Another instance of the application is running! Shut it down to run the application!' );
end.

MutexUtility.pas:

unit MutexUtility;

interface

type
  TMutexUtility = class
    public
      class function initMutexName : string;
      class function tryCreateMutex( mutexName_ : string; var hMutex_ : THandle ) : boolean;
      class procedure releaseMutex( var hMutex_ : THandle );
  end;


implementation

uses
    System.SysUtils
  , Windows
  ;


const
  CONST_name_MyApp = 'MyApp';
  CONST_version_MyApp = 1.1;
  CONST_name_MyAppMutex : string = '%s (version: %f, path: %s) startup mutex name';

class function TMutexUtility.initMutexName : string;
begin
  result := format( CONST_name_AppMutex, [CONST_name_App, CONST_version_MyApp, LowerCase( extractFilePath( paramStr( 0 ) ).Replace( '\', '/' ) )] );
end;

class function TMutexUtility.tryCreateMutex( mutexName_ : string; var hMutex_ : THandle ) : boolean;
var
  c : cardinal;
begin
  hMutex_ := createMutex( NIL, FALSE, pchar( mutexName_ ) );
  result := GetLastError <> ERROR_ALREADY_EXISTS;
end;

class procedure TMutexUtility.releaseMutex( var hMutex_ : THandle );
begin
  if ( hMutex_ <> 0 ) then
  begin
    closeHandle( hMutex_ );
    hMutex_ := 0;
  end;
end;


end.