unit uDGProcessList;
interface
uses
SysUtils,
Windows,
Classes,
Graphics,
TlHelp32,
ShellApi,
PsApi;
type
// type used to store information about a process
PDGProcessRec = ^TDGProcessRec;
TDGProcessRec = record
Name: WideString;
ExeName: WideString;
UserName: WideString;
Domain: WideString;
StartDateTime: TDateTime;
MemoryUsage: DWORD;
Usage: DWORD;
ProcessID: DWORD; // this process
DefaultHeapID: DWORD;
ModuleID: DWORD; // associated exe
ThreadCount: DWORD;
ParentProcessID: DWORD; // this process's parent process
PriClassBase: Longint; // Base priority of process's threads
end;// TDGProcessRec = record
type
// type used to get user name and domain
PTOKEN_USER = ^TOKEN_USER;
_TOKEN_USER = record
User: TSidAndAttributes;
end;
TOKEN_USER = _TOKEN_USER;
type
TUnitType = (utByte, utKiloByte, utMegaByte, utGigaByte);
type
TDGProcessList = class
PRIVATE// variables and methods
FList: TList;
function GetProcessRec(INDEX: Integer): TDGProcessRec;
function GetProcessFileName(dwProcessID: DWORD): WideString;
function GetProcessUserAndDomain(dwProcessID: DWORD;
var UserName, Domain: WideString): Boolean;
function GetProcessStartDateTime(dwProcessID: DWORD): TDateTime;
procedure SetProcessRec(INDEX: Integer; const Value: TDGProcessRec);
PUBLIC// methods
function Count: Integer;
function TerminateProcess(dwProcessID: DWORD): Boolean; OVERLOAD;
function TerminateProcess(const Name: WideString): Boolean; OVERLOAD;
function Exists(dwProcessID: DWORD): Boolean; OVERLOAD;
function Exists(dwProcessID: DWORD; var atIndex: Integer): Boolean; OVERLOAD;
function Exists(const Name: WideString): Boolean; OVERLOAD;
function Exists(const Name: WideString; var atIndex: Integer): Boolean; OVERLOAD;
function ProcessInfoToStr(Index: Integer): WideString;
function GetProcessIcon(Index: Integer;
const bSmallIcon: Boolean = True): TIcon; OVERLOAD;
function GetProcessIcon(const ExeName: WideString;
const bSmallIcon: Boolean = True): TIcon; OVERLOAD;
function GetProcessMemoryUsage(dwProcessID: DWORD;
const UnitType: TUnitType = utByte): DWORD;
procedure Clear;
procedure Delete(Index: Integer);
procedure Refresh;
PUBLIC// properties
property Process[INDEX: Integer]: TDGProcessRec
read GetProcessRec write SetProcessRec; DEFAULT;
PUBLIC// constructor and destructor
constructor Create;
destructor Destroy; override;
end;// TDGProcessList = class
implementation
{ TDGProcessList }
procedure TDGProcessList.Clear;
var
Index: Integer;
begin
for Index := FList.Count -1 downto 0 do
Delete(Index);
end;// procedure TDGProcessList.Clear;
function TDGProcessList.Count: Integer;
begin
Result := FList.Count;
end;// function TDGProcessList.Count: Integer;
constructor TDGProcessList.Create;
begin
FList := TList.Create;
end;// constructor TDGProcessList.Create;
procedure TDGProcessList.Delete(Index: Integer);
var
ProcessRec: PDGProcessRec;
begin
ProcessRec := FList[Index];
Dispose(ProcessRec);
FList.Delete(Index);
end;// procedure TDGProcessList.Delete(Index: Integer);
destructor TDGProcessList.Destroy;
begin
Clear;
FreeAndNil(FList);
inherited;
end;// destructor TDGProcessList.Destroy;
function TDGProcessList.Exists(dwProcessID: DWORD): Boolean;
var
Index: Integer;
begin
Result := Exists(dwProcessID, Index);
end;// function TDGProcessList.Exists(dwProcessID: DWORD): Boolean;
function TDGProcessList.Exists(dwProcessID: DWORD;
var atIndex: Integer): Boolean;
var
Index: Integer;
begin
Result := True;
for Index := 0 to FList.Count -1 do
if Process[Index].ProcessID = dwProcessID then begin
atIndex := Index;
Exit;
end;// if Process[Index].th32ProcessID = dwProcessID then begin
Result := False;
end;// function TDGProcessList.Exists(dwProcessID: DWORD;
function TDGProcessList.Exists(const Name: WideString): Boolean;
var
Index: Integer;
begin
Result := Exists(Name, Index);
end;// function TDGProcessList.Exists(const Name: AnsiString): Boolean;
function TDGProcessList.Exists(const Name: WideString;
var atIndex: Integer): Boolean;
var
Index: Integer;
begin
Result := True;
for Index := 0 to FList.Count -1 do
if SameText(Process[Index].Name, Name) then begin
atIndex := Index;
Exit;
end;// if SameText(Process[Index].Name, Name) then begin
Result := False;
end;// function TDGProcessList.Exists(const Name: AnsiString;
function TDGProcessList.GetProcessFileName(dwProcessID: DWORD): WideString;
var
Handle: THandle;
begin
Result := EmptyStr;
Handle := OpenProcess(PROCESS_QUERY_INFORMATION or PROCESS_VM_READ, False,
dwProcessID);
try
SetLength(Result, MAX_PATH);
if Handle <> 0 then begin
if GetModuleFileNameEx(Handle, 0, {$IFDEF UNICODE}PWideChar{$ELSE}PAnsiChar{$ENDIF}(Result), MAX_PATH) > 0 then
SetLength(Result, StrLen(PChar(Result)))
else
Result := EmptyStr;
end else begin// if Handle <> 0 then begin
if GetModuleFileNameEx(Handle, 0, {$IFDEF UNICODE}PWideChar{$ELSE}PAnsiChar{$ENDIF}(Result), MAX_PATH) > 0 then
SetLength(Result, StrLen(PChar(Result)))
else
Result := EmptyStr;
end;// if Handle <> 0 then begin
finally
CloseHandle(Handle);
end;// try
end;// function TDGProcessList.GetProcessFileName(dwProcessID: DWORD): AnsiString;
function TDGProcessList.GetProcessIcon(Index: Integer;
const bSmallIcon: Boolean = True): TIcon;
begin
Result := GetProcessIcon(Process[Index].ExeName);
end;// function TDGProcessList.GetProcessIcon(Index: Integer;
function TDGProcessList.GetProcessIcon(const ExeName: WideString;
const bSmallIcon: Boolean = True): TIcon;
var
FileInfo: _SHFILEINFO;
Flags: DWORD;
begin
if bSmallIcon then
Flags := SHGFI_ICON or SHGFI_SMALLICON or SHGFI_SYSICONINDEX
else
Flags := SHGFI_ICON or SHGFI_LARGEICON or SHGFI_SYSICONINDEX;
Result := TIcon.Create;
SHGetFileInfo({$IFDEF UNICODE}PWideChar{$ELSE}PAnsiChar{$ENDIF}(ExeName), 0, FileInfo, SizeOf(FileInfo), Flags);
Result.Handle := FileInfo.hIcon;
end;// function TDGProcessList.GetProcessIcon(const ExeName: AnsiString;
function TDGProcessList.GetProcessMemoryUsage(dwProcessID: DWORD;
const UnitType: TUnitType = utByte): DWORD;
const
CFACTOR_BYTE = 1;
CFACTOR_KILOBYTE = CFACTOR_BYTE * 1024;
CFACTOR_MEGABYTE = CFACTOR_KILOBYTE * 1024;
CFACTOR_GIGABYTE = CFACTOR_MEGABYTE * 1024;
var
MemCounters: TProcessMemoryCounters;
hProcess: THandle;
begin
Result := 0;
MemCounters.cb := SizeOf(TProcessMemoryCounters);
hProcess := OpenProcess(PROCESS_ALL_ACCESS, False, dwProcessID);
if hProcess <> 0 then begin
if GetProcessMemoryInfo(hProcess, @MemCounters, SizeOf(MemCounters)) then
case UnitType of
utByte:
Result := MemCounters.WorkingSetSize div CFACTOR_BYTE;
utKiloByte:
Result := MemCounters.WorkingSetSize div CFACTOR_KILOBYTE;
utMegaByte:
Result := MemCounters.WorkingSetSize div CFACTOR_MEGABYTE;
utGigaByte:
Result := MemCounters.WorkingSetSize div CFACTOR_GIGABYTE;
end// case UnitType of
else
RaiseLastOSError;
CloseHandle(hProcess)
end;// if hProcess <> 0 then begin
end;// function TDGProcessList.GetProcessMemoryUsage(dwProcessID: DWORD;
function TDGProcessList.GetProcessRec(INDEX: Integer): TDGProcessRec;
begin
if (INDEX <= -1) or (INDEX >= FList.Count) then
raise Exception.Create('Index out of bounds');
Result := PDGProcessRec(FList[INDEX])^;
end;// function TDGProcessList.GetProcessRec(INDEX: Integer): TDGProcessRec;
function TDGProcessList.GetProcessStartDateTime(
dwProcessID: DWORD): TDateTime;
function FileTimeToDateTime(ft: TFileTime): TDateTime;
var
ft1: TFileTime;
st: TSystemTime;
begin
if ft.dwLowDateTime + ft.dwHighDateTime = 0 then
Result := 0
else
begin
FileTimeToLocalFileTime(ft, ft1);
FileTimeToSystemTime(ft1, st);
Result := SystemTimeToDateTime(st);
end;
end;
var
ftCreationTime, lpExitTime, ftKernelTime, ftUserTime: TFileTime;
hProcess: THandle;
begin
Result := 0;
hProcess := OpenProcess(PROCESS_ALL_ACCESS, False, dwProcessID);
if hProcess <> 0 then begin
if GetProcessTimes(hProcess, ftCreationTime, lpExitTime,
ftKernelTime, ftUserTime) then
Result := FileTimeToDateTime(ftCreationTime)
else
RaiseLastOSError;
CloseHandle(hProcess);
end;// if hProcess <> 0 then begin
end;// function TDGProcessList.GetProcessStartDateTime(
function TDGProcessList.GetProcessUserAndDomain(dwProcessID: DWORD;
var UserName, Domain: WideString): Boolean;
var
hToken: THandle;
cbBuf: Cardinal;
tokUser: PTOKEN_USER;
sidNameUse: SID_NAME_USE;
hProcess: THandle;
UserSize, DomainSize: DWORD;
bSuccess: Boolean;
begin
Result := False;
hProcess := OpenProcess(PROCESS_QUERY_INFORMATION, False, dwProcessID);
if hProcess <> 0 then begin
if OpenProcessToken(hProcess, TOKEN_QUERY, hToken) then begin
bSuccess := GetTokenInformation(hToken, TokenUser, nil, 0, cbBuf);
tokUser := nil;
while (not bSuccess) and
(GetLastError = ERROR_INSUFFICIENT_BUFFER) do begin
ReallocMem(tokUser, cbBuf);
bSuccess := GetTokenInformation(hToken, TokenUser, tokUser, cbBuf, cbBuf);
end;// while (not bSuccess) and...
CloseHandle(hToken);
if not bSuccess then
Exit;
UserSize := 0;
DomainSize := 0;
LookupAccountSid(nil, tokUser.User.Sid, nil, UserSize, nil, DomainSize, sidNameUse);
if (UserSize <> 0) and (DomainSize <> 0) then begin
SetLength(UserName, UserSize);
SetLength(Domain, DomainSize);
if LookupAccountSid(nil, tokUser.User.Sid, {$IFDEF UNICODE}PWideChar{$ELSE}PAnsiChar{$ENDIF}(UserName), UserSize,
{$IFDEF UNICODE}PWideChar{$ELSE}PAnsiChar{$ENDIF}(Domain), DomainSize, sidNameUse) then begin
Result := True;
UserName := StrPas(PChar(UserName));
Domain := StrPas(PChar(Domain));
end;// if LookupAccountSid(nil, tokUser.User.Sid, PAnsiChar(UserName), UserSize,
end;// if (UserSize <> 0) and (DomainSize <> 0) then begin
if bSuccess then
FreeMem(tokUser);
end;// if OpenProcessToken(hProcess, TOKEN_QUERY, hToken) then begin
CloseHandle(hProcess);
end;// if hProcess <> 0 then begin
end;// function TDGProcessList.GetProcessUserAndDomain(dwProcessID: DWORD;
function TDGProcessList.ProcessInfoToStr(Index: Integer): WideString;
const
CCRLF = #$D#$A;
CPROCESSREC_FMT = CCRLF +
'Name = %s' + CCRLF +
'ExeName = %s' + CCRLF +
'User name = %s' + CCRLF +
'Domain = %s' + CCRLF +
'Started = %s' + CCRLF +
'Memory usage = %d bytes' + CCRLF +
'Usage = %d' + CCRLF +
'Process ID = %d' + CCRLF +
'Default heap ID = %d' + CCRLF +
'Module ID = %d' + CCRLF +
'Threads = %d' + CCRLF +
'Parent process ID = %d' + CCRLF +
'Priority base class = %d' + CCRLF;
var
ProcessRec: TDGProcessRec;
begin
ProcessRec := Process[Index];
Result := Format(CPROCESSREC_FMT, [
ProcessRec.Name,
ProcessRec.ExeName,
ProcessRec.UserName,
ProcessRec.Domain,
DateTimeToStr(ProcessRec.StartDateTime),
ProcessRec.MemoryUsage,
ProcessRec.Usage,
ProcessRec.ProcessID,
ProcessRec.DefaultHeapID,
ProcessRec.ModuleID,
ProcessRec.ThreadCount,
ProcessRec.ParentProcessID,
ProcessRec.PriClassBase]);
end;// function TDGProcessList.ProcessInfoToStr(Index: Integer): AnsiString;
procedure TDGProcessList.Refresh;
var
ProcessEntry32: TProcessEntry32;
ProcessRec: PDGProcessRec;
hSnapshot: THandle;
UserName: WideString;
Domain: WideString;
begin
Clear;
hSnapshot := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0);
ProcessEntry32.dwSize := SizeOf(TProcessEntry32);
if Process32First(hSnapshot, ProcessEntry32) then
repeat
New(ProcessRec);
ProcessRec^.Name := pchar(StrPas(ProcessEntry32.szExeFile));
ProcessRec^.ExeName := GetProcessFileName(ProcessEntry32.th32ProcessID);
if GetProcessUserAndDomain(ProcessEntry32.th32ProcessID,
UserName, Domain) then begin
ProcessRec^.UserName := UserName;
ProcessRec^.Domain := Domain;
end;// if GetProcessUserAndDomain(ProcessEntry32.th32ProcessID,
ProcessRec^.StartDateTime := GetProcessStartDateTime(
ProcessEntry32.th32ProcessID);
ProcessRec^.MemoryUsage := GetProcessMemoryUsage(
ProcessEntry32.th32ProcessID);
ProcessRec^.Usage := ProcessEntry32.cntUsage;
ProcessRec^.ProcessID := ProcessEntry32.th32ProcessID;
ProcessRec^.DefaultHeapID := ProcessEntry32.th32DefaultHeapID;
ProcessRec^.ModuleID := ProcessEntry32.th32ModuleID;
ProcessRec^.ThreadCount := ProcessEntry32.cntThreads;
ProcessRec^.ParentProcessID := ProcessEntry32.th32ParentProcessID;
ProcessRec^.PriClassBase := ProcessEntry32.pcPriClassBase;
FList.Add(ProcessRec);
until NOT Process32Next(hSnapshot, ProcessEntry32);
if FList.Count > 0 then
Delete(0);
if hSnapshot <> 0 then
CloseHandle(hSnapshot);
end;// procedure TDGProcessList.Refresh;
procedure TDGProcessList.SetProcessRec(INDEX: Integer;
const Value: TDGProcessRec);
begin
PDGProcessRec(FList[INDEX])^ := Value;
end;// procedure TDGProcessList.SetProcessRec(INDEX: Integer;
function TDGProcessList.TerminateProcess(dwProcessID: DWORD): Boolean;
var
hProcess: THandle;
begin
Result := False;
hProcess := OpenProcess(PROCESS_ALL_ACCESS, False, dwProcessID);
if hProcess <> 0 then begin
Result := Windows.TerminateProcess(hProcess, 0);
CloseHandle(hProcess)
end;// if hProcess <> 0 then begin
end;// function TDGProcessList.TerminateProcess(dwProcessID: DWORD): Boolean;
function TDGProcessList.TerminateProcess(const Name: WideString): Boolean;
var
Index: Integer;
begin
Result := False;
for Index := 0 to FList.Count -1 do
if SameText(Process[Index].Name, Name) then begin
Result := TerminateProcess(Process[Index].ProcessID);
Exit;
end;// if SameText(Process[Index].Name, Name) then begin
end;// function TDGProcessList.TerminateProcess(const Name: AnsiString): Boolean;
end.// unit uDGProcessList;
Usage:
uses
uDGProcessList;
How to fill a memo called Memo1 with all processes along with it's information
procedure TForm1.Button1Click(Sender: TObject);
var
Index: Integer;
ProcessList: TDGProcessList;
begin
ProcessList := TDGProcessList.Create;
ProcessList.Refresh;
Memo1.Clear;
for Index := 0 to ProcessList.Count -1 do
Memo1.Text := Memo1.Text + ProcessList.ProcessInfoToStr(Index);
FreeAndNil(ProcessList);
end;
How to terminate Notepad for instance
procedure TForm1.Button1Click(Sender: TObject);
var
Index: Integer;
ProcessList: TDGProcessList;
begin
ProcessList := TDGProcessList.Create;
ProcessList.Refresh;
ProcessList.Exists('notepad.exe', Index);
if (Index > 0) and (Index < ProcessList.Count) then
ProcessList.TerminateProcess(ProcessList[Index].ProcessID);
FreeAndNil(ProcessList);
end;
