I want to make a Task Manager program that displays this information:
Image name
memory usage
PID
How can I do this?
You don't need the J(WS)CL therefore, there is a simple WinAPI call that does almost all you want, and this is CreateToolhelp32Snapshot. To get a snapshot of all running processes, you have to call it as follows:
var
snapshot: THandle;
begin
snapshot := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0);
Now you have a list of all running processes. You can navigate through this list with the Process32First and Process32Next functions, the list entries are PROCESSENTRY32-structures (which contain, amongst others, the process ID and image name).
uses
Windows, TLHelp32, SysUtils;
var
snapshot: THandle;
ProcEntry: TProcessEntry32;
s: String;
begin
snapshot := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0);
if (snapshot <> INVALID_HANDLE_VALUE) then begin
ProcEntry.dwSize := SizeOf(ProcessEntry32);
if (Process32First(snapshot, ProcEntry)) then begin
s := ProcEntry.szExeFile;
// s contains image name of the first process
while Process32Next(snapshot, ProcEntry) do begin
s := ProcEntry.szExeFile;
// s contains image name of the current process
end;
end;
end;
CloseHandle(snapshot);
However, memory consumption information doesn't seem to be included, but you can get this via another simple API call, GetProcessMemoryInfo
uses
psAPI;
var
pmc: TProcessMemoryCounters;
begin
pmc.cb := SizeOf(pmc) ;
if GetProcessMemoryInfo(processID, #pmc, SizeOf(pmc)) then
// Usage in Bytes: pmc.WorkingSetSize
else
// fail
You just have to call this function with the process IDs retrieved from the snapshot.
Use the PSAPI (Process Status API).
The open source JCL has a Delphi wrapper for the PSAPI.
There are some more good stackoverflow Delphi PSAPI questions you can check for answers.
--jeroen
you can use the WMI Win32_Process class to get all the running process info. addtionally you can check the Win32_PerfFormattedData_PerfProc_Process class to get the performance counters related to CPU and memory usage.
Check this sample
program WMIProcessInfo;
{$APPTYPE CONSOLE}
uses
SysUtils
,ActiveX
,ComObj
,Variants;
procedure GetWin32_Process;
var
objWMIService : OLEVariant;
colItems : OLEVariant;
colItem : OLEVariant;
oEnum : IEnumvariant;
iValue : LongWord;
User : OLEVariant;
Domain : OLEVariant;
function GetWMIObject(const objectName: String): IDispatch;
var
chEaten: Integer;
BindCtx: IBindCtx;
Moniker: IMoniker;
begin
OleCheck(CreateBindCtx(0, bindCtx));
OleCheck(MkParseDisplayName(BindCtx, StringToOleStr(objectName), chEaten, Moniker));
OleCheck(Moniker.BindToObject(BindCtx, nil, IDispatch, Result));
end;
begin
objWMIService := GetWMIObject('winmgmts:\\localhost\root\cimv2');
colItems := objWMIService.ExecQuery('SELECT * FROM Win32_Process','WQL',0);
oEnum := IUnknown(colItems._NewEnum) as IEnumVariant;
WriteLn(Format('%-20s %6s %10s %10s %10s',['Caption','PID','User','Domain','Working Set ( Kb Memory)']));
while oEnum.Next(1, colItem, iValue) = 0 do
begin
colItem.GetOwner(User,Domain);
if colItem.GetOwner( User, Domain ) =0 then //get the user and domain
WriteLn(Format('%-20s %6s %10s %10s %10s',[colItem.Caption,colItem.ProcessId,User,Domain,colItem.WorkingSetSize / 1024]))
else
WriteLn(Format('%-20s %6s %10s %10s %10s',[colItem.Caption,colItem.ProcessId,'','',colItem.WorkingSetSize / 1024]));
end;
end;
begin
try
CoInitialize(nil);
try
GetWin32_Process;
Readln;
finally
CoUninitialize;
end;
except
on E:Exception do
Begin
Writeln(E.Classname, ': ', E.Message);
Readln;
End;
end;
end.
In Jwscl there is a class that can do this for you (JwsclTerminalServer):
var
ATerminalServer: TJwTerminalServer;
i: Integer;
begin
// Create Terminal Server instance and allocate memory for it
ATerminalServer := TjwTerminalServer.Create;
// Set servername (only in case of remote server)
ATerminalServer.Server := 'TS001';
// Remember that EnumerateProcesses will automatically connect to the
// Terminal Server for you. The connect function raises an Exception
// if the connection attempt was unsuccessfull, so better use try..except
try
if ATerminalServer.EnumerateProcesses then
begin
// Now loop through the list
for i := 0 to ATerminalServer.Processes.Count - 1 do
begin
Memo1.Lines.Add(ATerminalServer.Processes[i].ProcessName);
end;
end;
except
on E: EJwsclWinCallFailedException do
begin
// Handle Exception here
end;
end;
// Free Memory
ATerminalServer.Free;
end;
Although the unit is aimed at Terminal Server this part works both with and without and as a bonus you can use it on remote systems as well.
For each process detailed information is returned, check the docs for details.
For memory usage you can use the ProcessMemUsage and ProcessVirtualSize properties, for the Pid there is the ProcessId property
ProcessInfo provides basic information about running processes in Windows. It is open-source, and contains a demo of a task manager.
Related
Good afternoon,
I need lock CTRL+ALT+DEL combination using SetWindowsHookEx and today i have done a code and don't is working until now.
This code is executing in a dll ( this dll is my software ) that is injected in other process.
So, how i can adapt this code below to work?
const
WH_KEYBOARD_LL = 13;
LLKHF_ALTDOWN = $20;
type
KBDLLHOOKSTRUCT = record
vkCode: DWORD;
scanCode: DWORD;
flags: DWORD;
time: DWORD;
dwExtraInfo: Longint ;
end;
var
hhkLowLevelKybd : HHOOK;
FoldProc : LongInt;
hSASWnd : HWND;
hThread : Cardinal;
{$R *.dfm}
Function LowLevelKeyboardProc(nCode : Integer; wParam : Longint; var LParam: KBDLLHOOKSTRUCT) : Longint; stdcall;
var
fEatKeystroke : Boolean;
dwThreadId : Cardinal;
begin
If (nCode = HC_ACTION) Then
begin
If (wParam = WM_KEYDOWN) Or
(wParam = WM_SYSKEYDOWN) Or
(wParam = WM_KEYUP) Or
(wParam = WM_SYSKEYUP) Then
begin
fEatKeystroke :=
(((GetKeyState(VK_CONTROL) And $8000) <> 0) And
((LParam.flags And LLKHF_ALTDOWN ) <> 0) And
(LParam.vkCode = VK_DELETE));
End;
If fEatKeystroke Then
Result := -1
Else
Result := CallNextHookEx(0, nCode, wParam, LongInt(#LParam));
End;
end;
////////// FormCreate event here ///////////
hhkLowLevelKybd := 0;
hhkLowLevelKybd := SetWindowsHookEx(WH_KEYBOARD_LL, #LowLevelKeyboardProc,
HInstance, 0);
end.
Windows does not allow you to intercept Ctrl+Alt+Del for security reasons. Earlier versions (pre-Vista?) used to allow it by replacing the GINA DLL, but it's not been allowed for years.
That key combination is known as a secure attention sequence which is guaranteed to be trustworthy as part of the login process.
If your goal is to only allow your application to be run, you can configure it to act in kiosk mode if you're running a suitable version of Windows, as shown in Set up a device for anyone to use (kiosk mode) at TechNet which #LURD kindly provided.
By design it's impossible to trap or block Ctrl+Alt+Del (The Secure Attention Sequence). There is however a commercial library available (disclaimer: I am the author), SasLibEx.
SasLibEx: a library that can simulate or block the Secure Attention
Sequence (Ctrl+Alt+Del) but it can even unlock a
workstation or session without entering or needing the user’s
credentials (and many more things)
See this screencast for a demo.
Impossible. The Ctl-Alt-Del gets trapped in the Kernel and never makes it to the user mode space where your app is running.
I have had to do this on kiosks systems (using Win XP and Vista) and I did it with a keyboard filter driver (which runs in the kernel) that swaps out the scan codes when the key are pressed.
Not is impossible, see the following code:
program Project1;
{$APPTYPE CONSOLE}
{$R *.res}
uses
SysUtils,
Windows,
Registry,
vcl.Dialogs;
procedure DisableCtrAltDel(boolState: Boolean);
var
SystemReg: TRegistry;
Data: Array [1 .. 48] of Byte;
i: Byte;
begin
try
for i := 1 to 48 do
Data[i] := $00;
Data[9] := $09;
Data[15] := $5B;
Data[16] := $E0;
Data[19] := $5C;
Data[20] := $E0;
Data[23] := $5D;
Data[24] := $E0;
Data[27] := $44;
Data[31] := $1D;
Data[35] := $38;
Data[39] := $1D;
Data[40] := $E0;
Data[43] := $38;
Data[44] := $E0;
try
SystemReg := TRegistry.Create;
with SystemReg do
begin
RootKey := HKEY_LOCAL_MACHINE;
OpenKey('\System\CurrentControlSet\Control\Keyboard Layout', True);
if boolState then
WriteBinaryData('Scancode Map', Data, SizeOf(Data))
else
DeleteValue('Scancode Map');
MessageDlg('Restart Windows in order the changes to take effect!',
mtInformation, [mbOK], 0);
CloseKey;
end;
finally
SystemReg.Free;
end;
except
MessageDlg
('Error occurred while trying to disable ctrl+alt+del and Task Manager',
mtWarning, [mbOK], 0);
end;
end;
begin
try
DisableCtrAltDel(True);
except
on E: Exception do
Writeln(E.ClassName, ': ', E.Message);
end;
end.
Reference
I want the Firebird backup tool gbak to write its output to a Delphi stream (with no intermediate file). There is a command line parameter to write to stdout rather than a file. I then use the Execute method in JEDI's JclSysUtils to launch gbak and process that output.
It looks like this:
procedure DoBackup;
var
LBackupAbortFlag: Boolean;
LBackupStream: TStringStream;
begin
LBackupAbortFlag := False;
LBackupStream := TStringStream.Create;
try
Execute('"C:\path to\gbak.exe" -b -t -v -user SYSDBA -pas "pw" <db> stdout',
LBackupStream.WriteString, // Should process stdout (backup)
SomeMemo.Lines.Append, // Should process stderr (log)
True, // Backup is "raw"
False, // Log is not
#LBackupAbortFlag);
LBackupStream.SaveToFile('C:\path to\output.fbk');
finally
LBackupStream.Free;
end;
end;
The problem is that the output file is way too small to contain that actual backup. Still I see elements of the file's content. I tried different stream types, but that doesn't seem to make a difference. What could be going wrong here?
Update
To be clear: other solutions are welcome as well. Most of all, I need something reliable. That's why I went with JEDI in the first place, not to reinvent such a thing. Then, it would be nice, if it would be not too complicated.
My first answer is effective when you wish to merge stdout and stderr. However, if you need to keep these separate, that approach is no use. And I can now see, from a closer reading of your question, and your comments, that you do wish to keep the two output streams separate.
Now, it is not completely straightforward to extend my first answer to cover this. The problem is that the code there uses blocking I/O. And if you need to service two pipes, there is an obvious conflict. A commonly used solution in Windows is asynchronous I/O, known in the Windows world as overlapped I/O. However, asynchronous I/O is much more complex to implement than blocking I/O.
So, I'm going to propose an alternative approach that still uses blocking I/O. If we want to service multiple pipes, and we want to use blocking I/O then the obvious conclusion is that we need one thread for each pipe. This is easy to implement – much easier than the asynchronous option. We can use almost identical code but move the blocking read loops into threads. My example, re-worked in this way, now looks like this:
{$APPTYPE CONSOLE}
uses
SysUtils, Classes, Windows;
type
TProcessOutputPipe = class
private
Frd: THandle;
Fwr: THandle;
public
constructor Create;
destructor Destroy; override;
property rd: THandle read Frd;
property wr: THandle read Fwr;
procedure CloseWritePipe;
end;
constructor TProcessOutputPipe.Create;
const
PipeSecurityAttributes: TSecurityAttributes = (
nLength: SizeOf(TSecurityAttributes);
bInheritHandle: True
);
begin
inherited;
Win32Check(CreatePipe(Frd, Fwr, #PipeSecurityAttributes, 0));
Win32Check(SetHandleInformation(Frd, HANDLE_FLAG_INHERIT, 0));//don't inherit read handle of pipe
end;
destructor TProcessOutputPipe.Destroy;
begin
CloseHandle(Frd);
if Fwr<>0 then
CloseHandle(Fwr);
inherited;
end;
procedure TProcessOutputPipe.CloseWritePipe;
begin
CloseHandle(Fwr);
Fwr := 0;
end;
type
TReadPipeThread = class(TThread)
private
FPipeHandle: THandle;
FStream: TStream;
protected
procedure Execute; override;
public
constructor Create(PipeHandle: THandle; Stream: TStream);
end;
constructor TReadPipeThread.Create(PipeHandle: THandle; Stream: TStream);
begin
inherited Create(False);
FPipeHandle := PipeHandle;
FStream := Stream;
end;
procedure TReadPipeThread.Execute;
var
Buffer: array [0..4096-1] of Byte;
BytesRead: DWORD;
begin
while ReadFile(FPipeHandle, Buffer, SizeOf(Buffer), BytesRead, nil) and (BytesRead<>0) do begin
FStream.WriteBuffer(Buffer, BytesRead);
end;
end;
function ReadOutputFromExternalProcess(const ApplicationName, CommandLine: string; stdout, stderr: TStream): DWORD;
var
stdoutPipe, stderrPipe: TProcessOutputPipe;
stdoutThread, stderrThread: TReadPipeThread;
StartupInfo: TStartupInfo;
ProcessInfo: TProcessInformation;
lpApplicationName: PChar;
ModfiableCommandLine: string;
begin
if ApplicationName='' then
lpApplicationName := nil
else
lpApplicationName := PChar(ApplicationName);
ModfiableCommandLine := CommandLine;
UniqueString(ModfiableCommandLine);
stdoutPipe := nil;
stderrPipe := nil;
stdoutThread := nil;
stderrThread := nil;
try
stdoutPipe := TProcessOutputPipe.Create;
stderrPipe := TProcessOutputPipe.Create;
ZeroMemory(#StartupInfo, SizeOf(StartupInfo));
StartupInfo.cb := SizeOf(StartupInfo);
StartupInfo.dwFlags := STARTF_USESHOWWINDOW or STARTF_USESTDHANDLES;
StartupInfo.wShowWindow := SW_HIDE;
StartupInfo.hStdOutput := stdoutPipe.wr;
StartupInfo.hStdError := stderrPipe.wr;
Win32Check(CreateProcess(lpApplicationName, PChar(ModfiableCommandLine), nil, nil, True,
CREATE_NO_WINDOW or NORMAL_PRIORITY_CLASS, nil, nil, StartupInfo, ProcessInfo));
stdoutPipe.CloseWritePipe;//so that the process is able to terminate
stderrPipe.CloseWritePipe;//so that the process is able to terminate
stdoutThread := TReadPipeThread.Create(stdoutPipe.rd, stdout);
stderrThread := TReadPipeThread.Create(stderrPipe.rd, stderr);
stdoutThread.WaitFor;
stderrThread.WaitFor;
Win32Check(WaitForSingleObject(ProcessInfo.hProcess, INFINITE)=WAIT_OBJECT_0);
Win32Check(GetExitCodeProcess(ProcessInfo.hProcess, Result));
finally
stderrThread.Free;
stdoutThread.Free;
stderrPipe.Free;
stdoutPipe.Free;
end;
end;
procedure Test;
var
stdout, stderr: TFileStream;
ExitCode: DWORD;
begin
stdout := TFileStream.Create('C:\Desktop\stdout.txt', fmCreate);
try
stderr := TFileStream.Create('C:\Desktop\stderr.txt', fmCreate);
try
ExitCode := ReadOutputFromExternalProcess('', 'cmd /c dir /s C:\Windows\system32', stdout, stderr);
finally
stderr.Free;
end;
finally
stdout.Free;
end;
end;
begin
Test;
end.
If you wish to add support for cancelling, then you would simply add in a call to TerminateProcess when the user cancelled. This would bring everything to a halt, and the function would return the exit code that you supplied to TerminateProcess. I'm hesitant right now to suggest a cancellation framework for you, but I think that the code in this answer is now pretty close to meeting your requirements.
I expect that your code is failing because it tries to put binary data through a text oriented stream. In any case, it's simple enough to solve your problem with a couple of Win32 API calls. I don't see any compelling reason to use third party components for just this task.
Here's what you need to do:
Create a pipe that you will use as a communication channel between the two processes.
Create the gbak process and arrange for its stdout to be the write end of the pipe.
Read from the read end of the pipe.
Here's a simple demonstration program:
{$APPTYPE CONSOLE}
uses
SysUtils, Classes, Windows;
procedure ReadOutputFromExternalProcess(const ApplicationName, CommandLine: string; Stream: TStream);
const
PipeSecurityAttributes: TSecurityAttributes = (
nLength: SizeOf(PipeSecurityAttributes);
bInheritHandle: True
);
var
hstdoutr, hstdoutw: THandle;
StartupInfo: TStartupInfo;
ProcessInfo: TProcessInformation;
lpApplicationName: PChar;
ModfiableCommandLine: string;
Buffer: array [0..4096-1] of Byte;
BytesRead: DWORD;
begin
if ApplicationName='' then begin
lpApplicationName := nil;
end else begin
lpApplicationName := PChar(ApplicationName);
end;
ModfiableCommandLine := CommandLine;
UniqueString(ModfiableCommandLine);
Win32Check(CreatePipe(hstdoutr, hstdoutw, #PipeSecurityAttributes, 0));
Try
Win32Check(SetHandleInformation(hstdoutr, HANDLE_FLAG_INHERIT, 0));//don't inherit read handle of pipe
ZeroMemory(#StartupInfo, SizeOf(StartupInfo));
StartupInfo.cb := SizeOf(StartupInfo);
StartupInfo.dwFlags := STARTF_USESHOWWINDOW or STARTF_USESTDHANDLES;
StartupInfo.wShowWindow := SW_HIDE;
StartupInfo.hStdOutput := hstdoutw;
StartupInfo.hStdError := hstdoutw;
if not CreateProcess(
lpApplicationName,
PChar(ModfiableCommandLine),
nil,
nil,
True,
CREATE_NO_WINDOW or NORMAL_PRIORITY_CLASS,
nil,
nil,
StartupInfo,
ProcessInfo
) then begin
RaiseLastOSError;
end;
CloseHandle(ProcessInfo.hProcess);
CloseHandle(ProcessInfo.hThread);
CloseHandle(hstdoutw);//close the write end of the pipe so that the process is able to terminate
hstdoutw := 0;
while ReadFile(hstdoutr, Buffer, SizeOf(Buffer), BytesRead, nil) and (BytesRead<>0) do begin
Stream.WriteBuffer(Buffer, BytesRead);
end;
Finally
CloseHandle(hstdoutr);
if hstdoutw<>0 then begin
CloseHandle(hstdoutw);
end;
End;
end;
procedure Test;
var
Stream: TFileStream;
begin
Stream := TFileStream.Create('C:\Desktop\out.txt', fmCreate);
Try
ReadOutputFromExternalProcess('', 'cmd /c dir /s C:\Windows\system32', Stream);
Finally
Stream.Free;
End;
end;
begin
Test;
end.
I am looking for a way to be able to retrieve IP Subnet mask of the computer I am currently
running on at run time, in Delphi.
Is there a way in code for me to retrieve the subnet mask and store it so that I may use it in other operations?
Thanks
You can use the Win32_NetworkAdapterConfiguration WMI class and the IPSubnet property.
Try this sample code
{$APPTYPE CONSOLE}
uses
SysUtils,
ActiveX,
ComObj,
Variants;
function VarArrayToStr(const vArray: variant): string;
function _VarToStr(const V: variant): string;
var
Vt: integer;
begin
Vt := VarType(V);
case Vt of
varSmallint,
varInteger : Result := IntToStr(integer(V));
varSingle,
varDouble,
varCurrency : Result := FloatToStr(Double(V));
varDate : Result := VarToStr(V);
varOleStr : Result := WideString(V);
varBoolean : Result := VarToStr(V);
varVariant : Result := VarToStr(Variant(V));
varByte : Result := char(byte(V));
varString : Result := String(V);
varArray : Result := VarArrayToStr(Variant(V));
end;
end;
var
i : integer;
begin
Result := '[';
if (VarType(vArray) and VarArray)=0 then
Result := _VarToStr(vArray)
else
for i := VarArrayLowBound(vArray, 1) to VarArrayHighBound(vArray, 1) do
if i=VarArrayLowBound(vArray, 1) then
Result := Result+_VarToStr(vArray[i])
else
Result := Result+'|'+_VarToStr(vArray[i]);
Result:=Result+']';
end;
procedure GetWin32_NetworkAdapterConfigurationInfo;
const
WbemUser ='';
WbemPassword ='';
WbemComputer ='localhost';
wbemFlagForwardOnly = $00000020;
var
FSWbemLocator : OLEVariant;
FWMIService : OLEVariant;
FWbemObjectSet: OLEVariant;
FWbemObject : OLEVariant;
oEnum : IEnumvariant;
iValue : LongWord;
begin;
FSWbemLocator := CreateOleObject('WbemScripting.SWbemLocator');
FWMIService := FSWbemLocator.ConnectServer(WbemComputer, 'root\CIMV2', WbemUser, WbemPassword);
FWbemObjectSet:= FWMIService.ExecQuery('SELECT * FROM Win32_NetworkAdapterConfiguration Where IpEnabled=True','WQL',wbemFlagForwardOnly);
oEnum := IUnknown(FWbemObjectSet._NewEnum) as IEnumVariant;
while oEnum.Next(1, FWbemObject, iValue) = 0 do
begin
Writeln(Format('Caption %s',[String(FWbemObject.Caption)]));// String
if not VarIsNull(FWbemObject.DHCPServer) then
Writeln(Format('DHCPServer %s',[String(FWbemObject.DHCPServer)]));// String
if not VarIsNull(FWbemObject.IPAddress) then
Writeln(Format('IPAddress %s',[VarArrayToStr(FWbemObject.IPAddress)]));// array String
if not VarIsNull(FWbemObject.IPSubnet) then
Writeln(Format('IPSubnet %s',[VarArrayToStr(FWbemObject.IPSubnet)]));// array String
if not VarIsNull(FWbemObject.MACAddress) then
Writeln(Format('MACAddress %s',[VarArrayToStr(FWbemObject.MACAddress)]));// array String
Writeln;
FWbemObject:=Unassigned;
end;
end;
begin
try
CoInitialize(nil);
try
GetWin32_NetworkAdapterConfigurationInfo;
finally
CoUninitialize;
end;
except
on E:EOleException do
Writeln(Format('EOleException %s %x', [E.Message,E.ErrorCode]));
on E:Exception do
Writeln(E.Classname, ':', E.Message);
end;
Writeln('Press Enter to exit');
Readln;
end.
1) computer may be opart of different Nets/Subnets. Each network adapter usually has some. OR even more than one sometimes.
2) Even if physically you only have one network card, ypou also have loopback network - 127.x.x.x subnet. If you have some VPN installed like Hamachi or Comodo - that would give one more network adapter. Same for phone modem when connected. Same for virtual machines like XP Compatibility Mode. So you anyway would have to filter them one some criteria.
3) You can enlist network cards with FindAdaptor function of WMI: http://www.magsys.co.uk/delphi/magwmi.asp
Then you can read the properties of those adaptors.
There are also mentioned functions to set IP's, probably there are also functiones to read them.
Even if not, how to read properties is shown in the demo at the URL.
Which properties to read, you can determine using any WMI explorer out there.
Personally i ended with WMI Explorer of ks-soft.net plus WMI Tools of Microsoft.
You debug WMI request like you would do with SQLite, then pass it to WMI wrapper and read the result.
However, returning back to aforementioned Set IP Address functions, their sources probably already do contain properties names, just to save on exploring.
We want a program of ours in D7 to know if it was run via a ShellExecute command from one of our apps, or directly started by the user.
Is there a reliable way for a Delphi 7 program to determine the name of the program that ran it?
We of course could have our parent program use a command line argument or other flag, but we'd prefer the above approach.
TIA
There's no way to do what you want, I'm afraid. The application isn't told whether it's being run pro grammatically via ShellExecute (or CreateProcess), via a command line, a shortcut, or a double-click in Explorer.
Raymond Chen did an article a while back on this very topic, if I remember correctly; I'll see if I can find it and update my answer here.
Based on another answer and some code on Torry.net, I came to this function to get the parent process id. It seems to return a relevant number on Windows 7, and the windows functions it uses should be available at least since Win 2000.
uses Tlhelp32;
function GetProcessInfo(ProcessId: Cardinal; out ParentProcessId: Cardinal; out ExeFileName: string): Boolean;
var
hSnapShot: THandle;
ProcInfo: TProcessEntry32;
begin
hSnapShot := CreateToolHelp32Snapshot(TH32CS_SNAPPROCESS, 0);
if (hSnapShot <> THandle(-1)) then
try
ProcInfo.dwSize := SizeOf(ProcInfo);
if (Process32First(hSnapshot, ProcInfo)) then
repeat
if ProcInfo.th32ProcessID = ProcessId then
begin
ExeFileName := string(ProcInfo.szExeFile);
ParentProcessId := ProcInfo.th32ParentProcessID;
Result := True;
Exit;
end;
until not Process32Next(hSnapShot, ProcInfo);
finally
CloseHandle(hSnapShot);
end;
Result := False;
end;
procedure Test;
var
ProcessId, ParentProcessId, Dummy: Cardinal;
FileName: string;
begin
ProcessId := GetCurrentProcessId();
// Get info for current process
if GetProcessInfo(ProcessId, ParentProcessId, FileName) then
// Get info for parent process
if GetProcessInfo(ParentProcessId, Dummy, FileName) then
// Show it.
ShowMessage(IntToStr(ParentProcessId) + FileName);
end;
A word of caution! The parent process may no longer exist. Even worse, it's ID may have been recycled, causing this function to give you a different process than you asked for.
The simple answer is "No".
A more complex answer is "Not as easily as simply passing a command line param would be".
:)
What you need to do is identify the parent process of your process. Obtaining this is possible but not straightforward. Details of how to go about it can be obtained in this CodeProject article.
The biggest problem is that there is not strict hierarchical relationship between processes in Windows and PID (Process ID's) may be re-used. The PID you identify as your "parent" may not be your parent at all. If the parent process has subsequently terminated then it's PID may be re-used which could lead to some seemingly perplexing results ("My process was started by calc.exe? How is that possible?").
Trying to find bullet, water and idiot proof mechanisms to protect against the possible ways such a process might fail will be significantly more effort than simply devising and implementing a command line based convention between your launcher applications and the launchee by which the latter may identify the former.
A command line parameter is one such option but could be "spoofed" (if someone figures out what you are passing on the command line and for some reason could derive some value or benefit from mimicking this themselves).
Depending on how reliable and tamper proof you need the mechanism to be, this could still be enough however.
I've found getpids which does it using NtQueryInformationProcess to not only to obtain the parent process ID but also compare the process creation times - if the reported parent process was created after the child it means the reported parent ID has already been recycled.
Here is my Delphi unit I wrote to test it:
unit ProcInfo;
interface
uses
Windows, SysUtils;
function GetParentProcessId(ProcessID: DWORD; out ProcessImageFileName: string): DWORD; overload;
implementation
uses
PsApi;
var
hNtDll: THandle;
NtQueryInformationProcess: function(ProcessHandle: THandle; ProcessInformationClass: DWORD;
ProcessInformation: Pointer; ProcessInformationLength: ULONG; ReturnLength: PULONG): DWORD; stdcall;
const
UnicodeStringBufferLength = 1025;
type
PPEB = Pointer; // PEB from winternl.h not needed here
PPROCESS_BASIC_INFORMATION = ^PROCESS_BASIC_INFORMATION;
PROCESS_BASIC_INFORMATION = record
Reserved1: Pointer; // exit status
PebBaseAddress: PPEB;
Reserved2: array[0..1] of Pointer; // affinity mask, base priority
UniqueProcessId: ULONG_PTR;
Reserved3: Pointer; // parent process ID
end;
PProcessBasicInformation = ^TProcessBasicInformation;
TProcessBasicInformation = PROCESS_BASIC_INFORMATION;
PKernelUserTimes = ^TKernelUserTimes;
TKernelUserTimes = record
CreateTime: LONGLONG;
ExitTime: LONGLONG;
KernelTime: LONGLONG;
UserTime: LONGLONG;
end;
PUNICODE_STRING = ^UNICODE_STRING;
UNICODE_STRING = record
Length: USHORT;
MaximumLength: USHORT;
PBuffer: PChar;
Buffer: array[0..UnicodeStringBufferLength - 1] of Char;
end;
PUnicodeString = ^TUnicodeString;
TUnicodeString = UNICODE_STRING;
function GetProcessCreateTime(hProcess: THandle): LONGLONG;
var
ProcessTimes: TKernelUserTimes;
begin
Result := 0;
FillChar(ProcessTimes, SizeOf(ProcessTimes), 0);
if NtQueryInformationProcess(hProcess, 4, #ProcessTimes, SizeOf(ProcessTimes), nil) <> 0 then
Exit;
Result := ProcessTimes.CreateTime;
end;
function GetProcessParentId(hProcess: THandle): DWORD;
var
ProcessInfo: TProcessBasicInformation;
begin
Result := 0;
FillChar(ProcessInfo, SizeOf(ProcessInfo), 0);
if NtQueryInformationProcess(hProcess, 0, #ProcessInfo, SizeOf(ProcessInfo), nil) <> 0 then
Exit;
Result := DWORD(ProcessInfo.Reserved3);
end;
function GetProcessImageFileName(hProcess: THandle): string;
var
ImageFileName: TUnicodeString;
begin
Result := '';
FillChar(ImageFileName, SizeOf(ImageFileName), 0);
ImageFileName.Length := 0;
ImageFileName.MaximumLength := UnicodeStringBufferLength * SizeOf(Char);
ImageFileName.PBuffer := #ImageFileName.Buffer[0];
if NtQueryInformationProcess(hProcess, 27, #ImageFileName, SizeOf(ImageFileName), nil) <> 0 then
Exit;
SetString(Result, ImageFileName.PBuffer, ImageFileName.Length);
end;
function GetParentProcessId(ProcessId: DWORD; out ProcessImageFileName: string): DWORD;
var
hProcess, hParentProcess: THandle;
ProcessCreated, ParentCreated: LONGLONG;
begin
Result := 0;
ProcessImageFileName := '';
hProcess := OpenProcess(PROCESS_QUERY_INFORMATION, False, ProcessId);
if hProcess = 0 then
RaiseLastOSError;
try
Result := GetProcessParentId(hProcess);
if Result = 0 then
Exit;
ProcessCreated := GetProcessCreateTime(hProcess);
finally
CloseHandle(hProcess);
end;
hParentProcess := OpenProcess(PROCESS_QUERY_INFORMATION, False, Result);
if hParentProcess = 0 then
RaiseLastOSError;
try
ParentCreated := GetProcessCreateTime(hParentProcess);
if ParentCreated > ProcessCreated then
begin
Result := 0;
Exit;
end;
ProcessImageFileName := GetProcessImageFileName(hParentProcess);
finally
CloseHandle(hParentProcess);
end;
end;
initialization
hNtDll := GetModuleHandle('ntdll.dll');
if hNtDll <> 0 then
NTQueryInformationProcess := GetProcAddress(hNtDll, 'NtQueryInformationProcess');
end.
When I run the code from the IDE, I get the following results:
parent ID: 5140, parent image file name:
"\Device\HarddiskVolume1\Program Files\Embarcadero\RAD
Studio\8.0\bin\bds.exe"
so you may need to find a way to translate that into a "normal" path, e.g. "C:\Program Files\Embarcadero\RAD Studio\8.0\bin\bds.exe".
I'm trying to enumerate "friendly names" for COM ports. The ports may dynamically change as USB-serial devices are connected and disconnected at runtime.
Based on the possible methods described in this question, I am attempting to use the SetupDiGetClassDevs method.
I found this example code, but it is written for an older version of the setupapi unit (the original link to homepages.borland.com doesn't work of course).
I tried using the setupapi unit from the current JVCL(JVCL340CompleteJCL221-Build3845), but it doesn't seem to be compatible with Delphi 7. I get compiler errors:
if SetupDiGetDeviceRegistryProperty(DevInfoHandle,DeviceInfoData,
RegProperty,
#PropertyRegDataType,
#S1[1],RequiredSize,#RequiredSize) then begin
In the call to function SetupDiGetDeviceRegistryProperty,
I get the error "Types of actual and formal parameters must be identical" on the parameters #PropertyRegDataType, and #RequiredSize.
The Delphi3000 site says the code was written in 2004 and is intended for Delphi 7, so I'm not sure why it doesn't work with Delphi 7 now, unless setupapi has changed. Is anyone familiar with the changes to setupapi that could cause these problems?
I'm testing with a simple console program. The uses statement is " windows,
sysutils,
classes,
setupAPI,
Registry;"
The main program is:
begin
ComPortStringList := SetupEnumAvailableComPorts;
for Index := 0 to ComPortStringList.Count - 1 do
writeln(ComPortStringList[Index]);
end;
end.
The following procedure is working correctly for me (in Windows 8.1). It is important to use the parameter KEY_READ in the TRegistry.Constructor.
procedure EnumComPorts(const Ports: TStringList);
var
nInd: Integer;
begin { EnumComPorts }
with TRegistry.Create(KEY_READ) do
try
RootKey := HKEY_LOCAL_MACHINE;
if OpenKey('hardware\devicemap\serialcomm', False) then
try
Ports.BeginUpdate();
try
GetValueNames(Ports);
for nInd := Ports.Count - 1 downto 0 do
Ports.Strings[nInd] := ReadString(Ports.Strings[nInd]);
Ports.Sort()
finally
Ports.EndUpdate()
end { try-finally }
finally
CloseKey()
end { try-finally }
else
Ports.Clear()
finally
Free()
end { try-finally }
end { EnumComPorts };
I was able to get some more specific suggestions by asking the question a different way with different tags.
It turns out there were errors in the delphi3000.com example code, and possibly errors in the JVCL code. After fixing the example code errors, I got it to work. I have not addressed the potential JVCL errors.
Here is the working code (as a simple console app) for enumerating the names of com ports:
{$APPTYPE CONSOLE}
program EnumComPortsTest;
uses
windows,
sysutils,
classes,
setupAPI,
Registry;
{$R *.RES}
var
ComPortStringList : TStringList;
(*
The function below returns a list of available COM-ports
(not open by this or an other process), with friendly names. The list is formatted as follows:
COM1: = Communications Port (COM1)
COM5: = NI Serial Port (Com5)
COM6: = NI Serial Port (Com6)
COM7: = USB Serial Port (COM7)
COM8: = Bluetooth Communications Port (COM8)
COM9: = Bluetooth Communications Port (COM9)
This code originally posted at http://www.delphi3000.com/articles/article_4001.asp?SK=
errors have been fixed so it will work with Delphi 7 and SetupAPI from JVCL
*)
function SetupEnumAvailableComPorts:TstringList;
// Enumerates all serial communications ports that are available and ready to
// be used.
// For the setupapi unit see
// http://homepages.borland.com/jedi/cms/modules/apilib/visit.php?cid=4&lid=3
var
RequiredSize: Cardinal;
GUIDSize: DWORD;
Guid: TGUID;
DevInfoHandle: HDEVINFO;
DeviceInfoData: TSPDevInfoData;
MemberIndex: Cardinal;
PropertyRegDataType: DWord;
RegProperty: Cardinal;
RegTyp: Cardinal;
Key: Hkey;
Info: TRegKeyInfo;
S1,S2: string;
hc: THandle;
begin
Result:=Nil;
//If we cannot access the setupapi.dll then we return a nil pointer.
if not LoadsetupAPI then exit;
try
// get 'Ports' class guid from name
GUIDSize := 1; // missing from original code - need to tell function that the Guid structure contains a single GUID
if SetupDiClassGuidsFromName('Ports',#Guid,GUIDSize,RequiredSize) then begin
//get object handle of 'Ports' class to interate all devices
DevInfoHandle:=SetupDiGetClassDevs(#Guid,Nil,0,DIGCF_PRESENT);
if Cardinal(DevInfoHandle)<>Invalid_Handle_Value then begin
try
MemberIndex:=0;
result:=TStringList.Create;
//iterate device list
repeat
FillChar(DeviceInfoData,SizeOf(DeviceInfoData),0);
DeviceInfoData.cbSize:=SizeOf(DeviceInfoData);
//get device info that corresponds to the next memberindex
if Not SetupDiEnumDeviceInfo(DevInfoHandle,MemberIndex,DeviceInfoData) then
break;
//query friendly device name LIKE 'BlueTooth Communication Port (COM8)' etc
RegProperty:=SPDRP_FriendlyName;{SPDRP_Driver, SPDRP_SERVICE, SPDRP_ENUMERATOR_NAME,SPDRP_PHYSICAL_DEVICE_OBJECT_NAME,SPDRP_FRIENDLYNAME,}
SetupDiGetDeviceRegistryProperty(DevInfoHandle,
DeviceInfoData,
RegProperty,
PropertyRegDataType,
NIL,0,RequiredSize);
SetLength(S1,RequiredSize);
if SetupDiGetDeviceRegistryProperty(DevInfoHandle,DeviceInfoData,
RegProperty,
PropertyRegDataType,
#S1[1],RequiredSize,RequiredSize) then begin
KEY:=SetupDiOpenDevRegKey(DevInfoHandle,DeviceInfoData,DICS_FLAG_GLOBAL,0,DIREG_DEV,KEY_READ);
if key<>INValid_Handle_Value then begin
FillChar(Info, SizeOf(Info), 0);
//query the real port name from the registry value 'PortName'
if RegQueryInfoKey(Key, nil, nil, nil, #Info.NumSubKeys,#Info.MaxSubKeyLen, nil, #Info.NumValues, #Info.MaxValueLen,
#Info.MaxDataLen, nil, #Info.FileTime) = ERROR_SUCCESS then begin
RequiredSize:= Info.MaxValueLen + 1;
SetLength(S2,RequiredSize);
if RegQueryValueEx(KEY,'PortName',Nil,#Regtyp,#s2[1],#RequiredSize)=Error_Success then begin
If (Pos('COM',S2)=1) then begin
//Test if the device can be used
hc:=CreateFile(pchar('\\.\'+S2+#0),
GENERIC_READ or GENERIC_WRITE,
0,
nil,
OPEN_EXISTING,
FILE_ATTRIBUTE_NORMAL,
0);
if hc<> INVALID_HANDLE_VALUE then begin
Result.Add(Strpas(PChar(S2))+': = '+StrPas(PChar(S1)));
CloseHandle(hc);
end;
end;
end;
end;
RegCloseKey(key);
end;
end;
Inc(MemberIndex);
until False;
//If we did not found any free com. port we return a NIL pointer.
if Result.Count=0 then begin
Result.Free;
Result:=NIL;
end
finally
SetupDiDestroyDeviceInfoList(DevInfoHandle);
end;
end;
end;
finally
UnloadSetupApi;
end;
end;
var
index : integer;
begin
ComPortStringList := SetupEnumAvailableComPorts;
if (ComPortStringList <> nil) and (ComPortStringList.Count > 0) then
for Index := 0 to ComPortStringList.Count - 1 do
writeln(ComPortStringList[Index]);
end.
Looks like some arguments of type PDWord were replaced by var DWord in SetupApi.pas. All you need is to remove '#' from these arguments in your code like that:
if SetupDiGetDeviceRegistryProperty(DevInfoHandle,DeviceInfoData,
RegProperty,
PropertyRegDataType,
#S1[1],RequiredSize,RequiredSize) then begin
Do you have "typed # operator" turned on? Project options, Compiler tab under "Syntax options". A lot of third party code breaks if that option is enabled.
For easier operation you might consider simply using the registry where those names are listed eg:
ErrCode := RegOpenKeyEx(
HKEY_LOCAL_MACHINE,
'HARDWARE\DEVICEMAP\SERIALCOMM',
0,
KEY_READ,
KeyHandle);
(I've ommited the hand-waving stuff).
You might also consider using WMI - see this example from Magenta Systems - you can get a pretty much everything hardware-related now.
I adapted below code from RRUZ answer for Serial Port class. Works fine under Win10 20H2.
{$APPTYPE CONSOLE}
uses
SysUtils,
ActiveX,
ComObj,
Variants;
procedure GetWin32_SerialPortInfo;
const
WbemUser ='';
WbemPassword ='';
WbemComputer ='localhost';
wbemFlagForwardOnly = $00000020;
var
FSWbemLocator : OLEVariant;
FWMIService : OLEVariant;
FWbemObjectSet: OLEVariant;
FWbemObject : OLEVariant;
oEnum : IEnumvariant;
iValue : LongWord;
begin;
FSWbemLocator := CreateOleObject('WbemScripting.SWbemLocator');
FWMIService := FSWbemLocator.ConnectServer(WbemComputer, 'root\CIMV2', WbemUser, WbemPassword);
FWbemObjectSet:= FWMIService.ExecQuery('SELECT * FROM Win32_SerialPort','WQL',wbemFlagForwardOnly);
oEnum := IUnknown(FWbemObjectSet._NewEnum) as IEnumVariant;
while oEnum.Next(1, FWbemObject, iValue) = 0 do
begin
// for other fields: https://learn.microsoft.com/en-us/windows/win32/cimwin32prov/win32-serialport
Writeln(Format('DeviceID %s',[String(FWbemObject.DeviceID)]));// String
Writeln(Format('Name %s',[String(FWbemObject.Name)]));// String
Writeln(Format('Description %s',[String(FWbemObject.Description)]));// String
FWbemObject:=Unassigned;
end;
end;
begin
try
CoInitialize(nil);
try
GetWin32_SerialPortInfo;
finally
CoUninitialize;
end;
except
on E:EOleException do
Writeln(Format('EOleException %s %x', [E.Message,E.ErrorCode]));
on E:Exception do
Writeln(E.Classname, ':', E.Message);
end;
Writeln('Press Enter to exit');
Readln;
end.
Output:
DeviceID COM7
Name Silicon Labs CP210x USB to UART Bridge (COM7)
Description Silicon Labs CP210x USB to UART Bridge
Press Enter to exit