uses
PSAPI, TlHelp32;
function GetProcessName(PID: DWORD;
var ProcessName:
string): DWORD;
var
dwReturn : DWORD;
hProc : Cardinal;
buffer :
array[0..MAX_PATH - 1]
of Char;
begin
dwReturn := 0;
Zeromemory(@buffer, sizeof(buffer));
hProc := OpenProcess(PROCESS_QUERY_INFORMATION
or PROCESS_VM_READ, FALSE, PID);
if hProc <> 0
then
begin
GetModulebaseName(hProc, 0, buffer, sizeof(buffer));
ProcessName := (
string(buffer));
CloseHandle(hProc);
end
else
dwReturn := GetLastError;
result := dwReturn;
end;
type
TPIDList =
array of DWORD;
function GetProcessList(
var ProcessList: TPIDList): DWORD;
function GetOSVersionInfo(
var Info: TOSVersionInfo): Boolean;
begin
FillChar(Info, SizeOf(TOSVersionInfo), 0);
Info.dwOSVersionInfoSize := SizeOf(TOSVersionInfo);
Result := GetVersionEx(TOSVersionInfo(Addr(Info)^));
if (
not Result)
then
begin
FillChar(Info, SizeOf(TOSVersionInfo), 0);
Info.dwOSVersionInfoSize := SizeOf(TOSVersionInfo);
Result := GetVersionEx(TOSVersionInfo(Addr(Info)^));
if (
not Result)
then
Info.dwOSVersionInfoSize := 0;
end;
end;
var
dwReturn : DWORD;
OS : TOSVersionInfo;
// EnumProcesses
PidProcesses : PDWORD;
PidWork : PDWORD;
BufferSize : Cardinal;
Needed : DWORD;
cntProcesses : Cardinal;
i : Cardinal;
// CreateToolhelp32Snapshot
hProcSnapShot: THandle;
pe32 : TProcessEntry32;
j : Cardinal;
begin
dwReturn := 0;
// What OS are we running on?
if GetOSVersionInfo(
OS)
then
begin
if (
OS.dwPlatformId = VER_PLATFORM_WIN32_NT)
and (
OS.dwMajorVersion = 4)
then
// WinNT and higher
begin
Needed := 0;
BufferSize := 1024;
GetMem(PidProcesses, BufferSize);
// make sure memory is allocated
if Assigned(PidProcesses)
then
begin
try
// enumerate the processes
if EnumProcesses(PidProcesses, BufferSize, Needed)
then
begin
dwReturn := 0;
cntProcesses := Needed
div sizeof(DWORD) - 1;
PidWork := PidProcesses;
setlength(ProcessList, cntProcesses);
// walk the processes
for i := 0
to cntProcesses - 1
do
begin
ProcessList[i] := PidWork^;
Inc(PidWork);
end;
end
else // EnumProcesses = False
dwReturn := GetLastError;
finally
// clean up no matter what happend
FreeMem(PidProcesses, BufferSize);
end;
end
else // GetMem = nil
dwReturn := GetLastError;
end
// Win 9x and higher except WinNT
else
begin
// make the snapshot
hProcSnapShot := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0);
if hProcSnapShot <> INVALID_HANDLE_VALUE
then
begin
pe32.dwSize := sizeof(TProcessEntry32);
j := 0;
setlength(ProcessList, j + 1);
if Process32First(hProcSnapShot, pe32)
then
begin
// first process
ProcessList[j] := pe32.th32ProcessID;
// walk the processes
while Process32Next(hProcSnapShot, pe32)
do
begin
Inc(j);
setlength(ProcessList, j + 1);
ProcessList[j] := pe32.th32ProcessID;
end;
end
else // Process32First = False
dwReturn := GetLastError;
CloseHandle(hProcSnapShot);
end
else // hSnapShot = INVALID_HANDLE_VALUE
dwReturn := GetLastError;
end;
end;
result := dwReturn;
end;
procedure TForm1.Button1Click(Sender: TObject);
var
retValue : DWORD;
ProcessList : TPIDList;
i : Integer;
ProcessName :
string;
PID : DWORD;
resourcestring
rsUnknown = '
unbekannt';
begin
// VCL causes last error to be set, even nothing has already happend :-/
SetLastError(0);
retValue := GetProcessList(ProcessList);
if retValue = 0
then
begin
for i := 0
to length(ProcessList) - 1
do
begin
PID := ProcessList[i];
if GetProcessName(ProcessList[i], ProcessName) <> 0
then
ProcessName := rsUnknown;
Listbox1.Items.Add(IntToStr(PID) + '
- ' + ProcessName);
end;
end
else
ShowMessage(SysErrorMessage(retValue));
end;