{
Author : Michael Puff - [url]http://developer.luckie-online.de[/url]
Date : 2005-05-29
License : PUBLIC DOMAIN
}
uses
PSAPI, TlHelp32;
type
TPIDList =
array of DWORD;
TStringDynArray =
array of string;
function GetProcessID(
const ProcName:
string;
var ID: DWORD): DWORD;
var
hProcSnap: THandle;
pe32: TProcessEntry32;
dw: DWORD;
begin
dw := 0;
hProcSnap := CreateToolHelp32SnapShot(TH32CS_SNAPPROCESS, 0);
if hProcSnap = 0
then
begin
pe32.dwSize := SizeOf(ProcessEntry32);
if Process32First(hProcSnap, pe32)
then
begin
while Process32Next(hProcSnap, pe32)
do
begin
if pos(ProcName, pe32.szExeFile) <> 0
then
begin
ID := pe32.th32ProcessID;
break;
end;
end;
end
else // Process32First = False
dw := GetLastError;
CloseHandle(hProcSnap);
end
else // hSnapShot = INVALID_HANDLE_VALUE
dw := GetLastError;
result := dw;
end;
function KillProcess(dwProcID, Wait: DWORD): Integer;
var
hProcess: Cardinal;
dw: DWORD;
begin
// open the process and store the process-handle
hProcess := OpenProcess(SYNCHRONIZE
or PROCESS_TERMINATE, False, dwProcID);
// kill it
if hProcess <> 0
then
begin
dw := Integer(TerminateProcess(hProcess, 1));
if dw <> 0
then
begin
// TerminateProcess returns immediately, so wie have to verify the result via
// WaitForSingleObject
dw := WaitForSingleObject(hProcess, Wait);
if dw = WAIT_FAILED
then
dw := GetLastError;
end
else // TerminateProcess = 0
dw := GetLastError;
CloseHandle(hProcess);
end
else // hProcess = INVALID_HANDLE_VALUE
dw := GetLastError;
result := dw;
end;
function GetProcessName(PID: DWORD;
var ProcessName:
string): DWORD;
var
dwReturn: DWORD;
hProcSnapShot: THandle;
pe32: TProcessEntry32;
begin
dwReturn := 0;
hProcSnapShot := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0);
if hProcSnapShot <> INVALID_HANDLE_VALUE
then
begin
pe32.dwSize := sizeof(TProcessEntry32);
if Process32First(hProcSnapShot, pe32)
then
begin
// first process
if PID = pe32.th32ProcessID
then
begin
ProcessName := pe32.szExeFile;
end;
// first process wasn't the one we wanted
// walk the rest
if ProcessName <> '
'
then
begin
// walk the processes
while Process32Next(hProcSnapShot, pe32)
do
begin
// found process
if PID = pe32.th32ProcessID
then
begin
ProcessName := pe32.szExeFile;
// exit
break;
end;
end;
end;
end
else // Process32First = False
dwReturn := GetLastError;
CloseHandle(hProcSnapShot);
end
else // hSnapShot = INVALID_HANDLE_VALUE
dwReturn := GetLastError;
result := dwReturn
end;
function GetProcessList(
var ProcessList: TPIDList): DWORD;
var
dwReturn: DWORD;
hProcSnapShot: THandle;
pe32: TProcessEntry32;
j: Cardinal;
begin
dwReturn := 0;
// 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;
result := dwReturn;
end;
procedure TForm1.Button1Click(Sender: TObject);
var
retValue: DWORD;
ProcessList: TPIDList;
i: Integer;
ProcessName:
string;
resourcestring
rsUnknown = '
unbekannt';
begin
// VCL causes last error to be set, even nothing has already happend :-/
SetLastError(0);
Listbox1.Clear;
retValue := GetProcessList(ProcessList);
if retValue = 0
then
begin
for i := 0
to length(ProcessList) - 1
do
begin
if GetProcessName(ProcessList[i], ProcessName) <> 0
then
ProcessName := rsUnknown;
Listbox1.Items.Add(IntToStr(ProcessList[i]) + '
- ' + ProcessName);
end;
end
else
ShowMessage(SysErrorMessage(retValue));
end;
procedure TForm1.Button2Click(Sender: TObject);
var
dw: DWORD;
begin
dw := KillProcess(StrToInt(Edit1.Text), 5000);
if dw <> 0
then
ShowMessage(SysErrorMessage(dw));
Button1.Click;
end;