Not getting path of various system processes by GetModuleFileNameEx() - delphi

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

Related

How to detect whether a SPECIFIC Delphi version is currently running?

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;

Delphi export HKEY_CURRENT_USER key not working - empty result file

I am trying to export a registry key using either TRegistry.SaveKey or RegSaveKey functions with no luck. All I get is an empty file 0 bytes. I have seen examples online none seems to be working on Windows10.
reg := TRegistry.Create;
reg.RootKey := HKEY_CURRENT_USER;
reg.Access := KEY_ALL_ACCESS;
if reg.OpenKey('\Software\MyCompanyName\MyApplication\', True) then
begin
reg.WriteInteger('background', Self.Color);
reg.SaveKey('HKEY_CURRENT_USER\Software\MyCompanyName\MyApplication', 'test.txt'); //not working
RegSaveKey(reg.CurrentKey, 'test.reg', nil); //creates empty file
end;
reg.CloseKey;
reg.Free;
Also if I extract existing key from RegEdit and then try to load it in the application using TRegistry.LoadKey or RegLoadKey nothing is happening
I do have admin right on the machine I run this.
Anyone familiar with the issue?
From the documentation of RegSaveKey:
The calling process must have the SE_BACKUP_NAME privilege enabled.
My guess is that RegSaveKey returning a value other than ERROR_SUCCESS. which your code does not check.
See also:
RegSaveKey returns ERROR_PRIVILEGE_NOT_HELD
Another thing to check for is that the destination file does not exists before you try to save, or else the function will fail (this is also mentioned in the documentation), and obviously that you have write permissions to the file location.
Here is a working example.
Be aware that you must run the program as administrator.
program SO59753973;
{$APPTYPE CONSOLE}
{$R *.res}
uses
Registry,
Windows,
System.SysUtils;
function NTSetPrivilege(sPrivilege: string; bEnabled: Boolean): Boolean;
var
hToken: THandle;
TokenPriv: TOKEN_PRIVILEGES;
PrevTokenPriv: TOKEN_PRIVILEGES;
ReturnLength: Cardinal;
errval:Cardinal;
begin
Result := True;
errval:=0;
// 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
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
if AdjustTokenPrivileges(hToken, False, TokenPriv, SizeOf(PrevTokenPriv),PrevTokenPriv, ReturnLength) then
Result := True
else
begin
errval:= GetLastError;
Result := errval = 0;
end;
end;
finally
CloseHandle(hToken);
end;
// test the return value of AdjustTokenPrivileges.
//Result := GetLastError = ERROR_SUCCESS;
if not Result then
raise Exception.Create(SysErrorMessage(errval));
end;
var
Reg: TRegistry;
sKeyFileName: String;
begin
try
if not NTSetPrivilege('SeBackupPrivilege',true) then
Exit;
sKeyFileName := 'C:\temp\tempReg.reg';
if FileExists(sKeyFileName) then
DeleteFile(sKeyFileName);
Reg := TRegistry.Create(KEY_ALL_ACCESS);
try
Reg.RootKey := HKEY_CURRENT_USER;
if Reg.SaveKey('\Software\Microsoft', sKeyFileName)
then
Writeln('Registry has been saved!')
else
Writeln('Failed to save registry, received error: ' + IntToStr(Reg.LastError) + '!');
finally
Reg.Free;
end;
except
on E: Exception do
Writeln(E.ClassName, ': ', E.Message);
end;
Readln;
end.
For restoring the registry, you must enable the SE_RESTORE_NAME in addition to the SE_BACKUP_NAME Privilege.
Code has been taken (and adapted) from this old forum post

Delphi reboot Windows

I'm using Windows 10 and I am logged in as Administrator.
When I try to reboot the system, all it does is it logs me off.
ExitWindowsEx(EWX_REBOOT and EWX_FORCE, 0);
Can someone please tell me why is this not rebooting?
So it seems that even though I am a administrator I need to set the rights with the following function
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;
// test the return value of AdjustTokenPrivileges.
Result := GetLastError = ERROR_SUCCESS;
if not Result then
raise Exception.Create(SysErrorMessage(GetLastError));
end;
like this :
procedure TMain.Neustart1Click(Sender: TObject);
const
SE_SHUTDOWN_NAME = 'SeShutdownPrivilege';
begin
NTSetPrivilege(SE_SHUTDOWN_NAME, True);
ExitWindowsEx(EWX_REBOOT or EWX_FORCE, 0);
end;
Now it works.
I was looking for a better solution to the one I had done about 5 years ago (posted below), I needed to do some tweaking for it to run on latest Delphi, older Delphi versions simply use Windows.AdjustTokenPrivileges. Code below is tried and tested since windows XP. Be careful - it works, make sure you save your work before running!
//Uses WinApi.Windows on Latest Delphi 10.3.2
function MyExitWindows(RebootParam: Longword): Boolean;
var
TTokenHd: THandle;
TTokenPvg: TTokenPrivileges;
cbtpPrevious: DWORD;
rTTokenPvg: TTokenPrivileges;
pcbtpPreviousRequired: DWORD;
tpResult: Boolean;
const
SE_SHUTDOWN_NAME = 'SeShutdownPrivilege';
begin
if Win32Platform = VER_PLATFORM_WIN32_NT then
begin
tpResult := OpenProcessToken(GetCurrentProcess(),
TOKEN_ADJUST_PRIVILEGES or TOKEN_QUERY,
TTokenHd);
if tpResult then
begin
tpResult := LookupPrivilegeValue(nil,
SE_SHUTDOWN_NAME,
TTokenPvg.Privileges[0].Luid);
TTokenPvg.PrivilegeCount := 1;
TTokenPvg.Privileges[0].Attributes := SE_PRIVILEGE_ENABLED;
cbtpPrevious := SizeOf(rTTokenPvg);
pcbtpPreviousRequired := 0;
if tpResult then
//Older Delphi - replace the WinApi. to read WinApi.AdjustTokenPrivileges
WinApi.Windows.AdjustTokenPrivileges(TTokenHd,
False,
TTokenPvg,
cbtpPrevious,
rTTokenPvg,
pcbtpPreviousRequired);
end;
end;
Result := ExitWindowsEx(RebootParam, 0);
end;
//Examples
//Shutdown the computer
MyExitWindows(EWX_POWEROFF or EWX_FORCE);
//Reboot the computer
MyExitWindows(EWX_REBOOT or EWX_FORCE);

Win7 IE11 IShellWindows returns 'Unknown Error' only on some machines

I use the following code to check, if there already exists an Internet Explorer 11 Tab with a given Url Location.
I started with code from here: http://francois-piette.blogspot.de/2013/01/internet-explorer-automation-part-1.html
function GetIERunningInstanceByUrl(FLogWriter: ILogWriter; const Url : String): IWebBrowser2;
function GetClassName(aHWND : HWND) : String;
var
L : Integer;
begin
SetLength(Result, MAX_PATH * SizeOf(Char));
L := WinApi.Windows.GetClassName(aHWND, PChar(Result), Length(Result));
SetLength(Result, L);
end;
var
aShWindows : IShellWindows;
aIdx : Integer;
aDisp: IDispatch;
aClassName: string;
begin
FLogWriter.LogMessage(ltDebug, 'GetIERunningInstanceByUrl / Url: ''' + Url + '''.');
aShWindows := CoShellWindows.Create;
if not Assigned(aShWindows) then begin
FLogWriter.LogMessage(ltDebug, 'GetIERunningInstanceByUrl / After CoShellWindows.Create, not Assigned(aShWindows) = TRUE.');
end;
FLogWriter.LogMessage(ltDebug, 'GetIERunningInstanceByUrl / aShWindows.Count: ' + IntToStr(aShWindows.Count) + '.');
for aIdx := 0 to aShWindows.Count - 1 do begin
aDisp := aShWindows.Item(aIdx);
if not Assigned(aDisp) then begin
FLogWriter.LogMessage(ltDebug, 'GetIERunningInstanceByUrl / After aDisp := aShWindows.Item(aIdx=' + IntToStr(aIdx) + '), not Assigned(aDisp) = TRUE.');
end
else begin
if not Supports(aDisp, IID_IWebBrowser2) then begin
FLogWriter.LogMessage(ltDebug, 'GetIERunningInstanceByUrl / Supports(aDisp, IID_IWebBrowser2) = FALSE.');
end
else begin
Result := aDisp as IWebBrowser2;
if not Assigned(Result) then begin
FLogWriter.LogMessage(ltDebug, 'GetIERunningInstanceByUrl / After Result := aDisp as IWebBrowser2, not Assigned(Result) = TRUE.');
end
else begin
aClassName := GetClassName(Result.HWND);
FLogWriter.LogMessage(ltDebug, 'GetIERunningInstanceByUrl / GetClassName(aShWindows.Item(aIdx=' + IntToStr(aIdx) + ').Result): ''' + aClassName + '''.');
end;
end;
end;
if Supports(aDisp, IID_IWebBrowser2) then begin
if Assigned(Result) then begin
if SameText(GetClassName(Result.HWND), 'IEFrame') then begin
//if SameText(Url, Result.LocationURL) then begin
if ContainsText(Result.LocationURL, Url) then begin
FLogWriter.LogMessage(ltDebug, 'GetIERunningInstanceByUrl / Found, Result.HWND: ' + IntToStr(Result.HWND) + ', Result.LocationURL: ''' + Result.LocationURL + '''.');
Exit;
end
else begin
FLogWriter.LogMessage(ltDebug, 'GetIERunningInstanceByUrl / Not found, ContainsText(Result.LocationURL, Url) = FALSE, Result.LocationURL: ''' + Result.LocationURL + ''' .');
end;
end
else begin
aClassName := GetClassName(Result.HWND);
FLogWriter.LogMessage(ltDebug, 'GetIERunningInstanceByUrl / Not found, SameText(GetClassName(Result.HWND), ''IEFrame'') = FALSE, aClassName: ''' + aClassName + ''' .');
end;
end;
end;
end;
// Not found
Result := nil;
FLogWriter.LogMessage(ltDebug, 'GetIERunningInstanceByUrl / Not found, After Result = nil, Url: ''' + Url + '''.');
end;
The application is installed on machines, that all have Windows 7 Professional Service Pack 1, 64Bit and Internet Explorer 11 (Version 11.0.9600.18762).
The code works fine on most machines, but there are some machines, where I get an 'Unknown error' in this method, after it was running correctly for several times.
When having the error once, the only way to get the application running again, is to logoff from windows and login again.
Unfortunatelly, I may not debug on those (production) machines, so I got to use poor man's debugging, logging every line... (that is also the reason, why my above code became a little bit ugly to read on some lines, sorry.)
Doing that, I found, that it must be something related to the IShellWindows interface.
10.08.2017 10:33:05 ThreadID: 0x00001A08 - GetIERunningInstanceByUrl / Url: 'https://example.com/'.
10.08.2017 10:33:05 ThreadID: 0x00001A08 - GetIERunningInstanceByUrl / aShWindows.Count: 3.
10.08.2017 10:33:05 ThreadID: 0x00001A08 - GetIERunningInstanceByUrl / GetClassName(aShWindows.Item(aIdx=0).Result): 'CabinetWClass'.
10.08.2017 10:33:05 ThreadID: 0x00001A08 - GetIERunningInstanceByUrl / Not found, SameText(GetClassName(Result.HWND), 'IEFrame') = FALSE, aClassName: 'CabinetWClass' .
10.08.2017 10:33:05 ThreadID: 0x00001A08 - Meldung - Exception: Unbekannter Fehler Retry: 1
(translation: 'Unbekannter Fehler' means 'Unknown error')
In the above log sample, it seems that only the first item from the List of 3 items can be iterated using IShellWindows. Then an exception is raised.
Any help would be appreciated...
I had a similar problem - or still have with a program that uses the IShellWindows interface. My experience is that it does not depend on the machine, but can happen on any machine, but I did not found out what to do to prevent it.
What helps for me is to stop all explorer processes (not the Internet Explorer process!). I do this from within my program, but you can also do this via the Task Manager for testing. If the Task Bar runs in a seperate Explorer process, you will have to stop that too.
After you have restarted the Explorer, the interface works again. This is slightly better than to have to log off, since you do not need to restart all your applications and you can do this from within your code, but this is of course still no good solution, since the Task Bar will be rebuild during this process.
The code I use to Close all Explorer processes and restart is the following:
function isexplorerwindow(exwnd: hwnd): boolean;
var
p: array[0..max_path] of Char;
begin
GetClassName(exwnd, p, SizeOf(p));
result := ((strcomp(p, 'CabinetWClass') = 0) or (strcomp(p, 'ExploreWClass') = 0));
end;
procedure restartshell;
var
wnd: hwnd;
pid: dword;
processhandle: thandle;
SL: tstringlist;
z: integer;
StartUpInfo: TStartUpInfo;
ProcessInfo: TProcessInformation;
begin
if messagebox(0, pchar(_('Restarting the shell will close all explorer windows and the task bar.') + #13#10 +
_('Do you really want to continue?')), __('Warning'), mb_yesno or mb_defbutton2 or mb_iconquestion) = idno then
Exit;
SL := tstringlist.Create;
wnd := getwindow(getdesktopwindow, gw_child);
while (wnd <> 0) do
begin
if isexplorerwindow(wnd) then
SL.Add(inttostr(wnd));
wnd := getwindow(wnd, gw_hwndnext);
end;
for z := 0 to SL.count - 1 do
postMessage(strtoint(SL[z]), $10, 0, 0);
SL.Free;
application.ProcessMessages;
sleep(1000);
application.ProcessMessages;
wnd := findwindow('Progman', nil);
if wnd > 0 then
begin
GetWindowThreadProcessId(wnd, pid);
if (pid > 0) then
begin
processhandle := OpenProcess(1, false, pid);
if (processhandle > 0) then
begin
TerminateProcess(processhandle, 0);
CloseHandle(processhandle);
end;
end;
end;
application.ProcessMessages;
sleep(1000);
application.ProcessMessages;
FillChar(StartUpInfo, SizeOf(StartUpInfo), #0);
StartUpInfo.cb := SizeOf(StartUpInfo);
StartUpInfo.dwFlags := STARTF_USESHOWWINDOW;
if not CreateProcess(nil, 'explorer.exe', nil, nil, false, CREATE_NEW_CONSOLE or NORMAL_PRIORITY_CLASS, nil, nil,
StartUpInfo, ProcessInfo) then
messagebeep(mb_iconstop);
You can try this. It should return the topmost IE window that is navigated to the given URL:
function TryGetWebBrowser(const URL: WideString; out Browser: IWebBrowser2): Boolean;
var
Handle: HWND;
Unused: OleVariant;
Location: OleVariant;
WndIface: IDispatch;
ShellWindows: IShellWindows;
begin
Result := False;
if Succeeded(CoCreateInstance(CLASS_ShellWindows, nil, CLSCTX_LOCAL_SERVER, IID_IShellWindows, ShellWindows)) then
begin
Unused := Unassigned;
Location := URL;
WndIface := ShellWindows.FindWindowSW(Location, Unused, SWC_BROWSER, Integer(Handle), SWFO_NEEDDISPATCH);
Result := Assigned(WndIface) and Succeeded(WndIface.QueryInterface(IWebBrowser2, Browser));
end;
end;

How to ensure only a single instance of my application runs?

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;

Resources