(*======================================================================*
| Project : |
| Unit : ProcListCls |
| |
| Notes : Class for listing and killing processes |
| |
| |
| Copyright (c) 2006 Michael Puff [MPu] |
| Url : [url]http://developer.michael-puff.de[/url] |
| Mail : [email]mpuff@michael-puff.de[/email] |
| |
| Version Date By Description |
| ------- ---------- ---- ------------------------------------------|
| 1.0 2006-03-25 MPu |
| |
*======================================================================*)
(*======================================================================*
| |
| COPYRIGHT NOTICE |
| |
| Copyright (c) 2001-2006, Michael Puff ["copyright holder(s)"] |
| All rights reserved. |
| |
| Redistribution and use in source and binary forms, with or without |
| modification, are permitted provided that the following conditions |
| are met: |
| |
| 1. Redistributions of source code must retain the above copyright |
| notice, this list of conditions and the following disclaimer. |
| 2. Redistributions in binary form must reproduce the above copyright |
| notice, this list of conditions and the following disclaimer in |
| the documentation and/or other materials provided with the |
| distribution. |
| 3. The name(s) of the copyright holder(s) may not be used to endorse |
| or promote products derived from this software without specific |
| prior written permission. |
| |
| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS |
| "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT |
| LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS |
| FORA PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE |
| REGENTS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, |
| INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, |
| BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; |
| LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER |
| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT |
| LIABILITY, OR TORT INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY |
| WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE |
| POSSIBILITY OF SUCH DAMAGE. |
| |
*======================================================================*)
unit ProcListCls;
interface
uses
Windows,
SysUtils,
Dialogs,
TlHelp32;
type
TProcess =
packed record
Filename:
string;
ProcID: DWORD;
ParentID: DWORD;
Priority: DWORD;
Threads: DWORD;
end;
TOnProcListStart =
procedure(Sender: TObject)
of object;
TOnProcListFinished =
procedure(Sender: TObject; CountProcs: Integer)
of object;
TOnProcRetrieve =
procedure(Sender: TObject; Process: TProcess)
of object;
TOnListFailure =
procedure(Sender: TObject; ErrorCode: Integer;
const ErrorString:
string)
of object;
TOnKillFailure =
procedure(Sender: TObject; ErrorCode: Integer;
const ErrorString:
string)
of object;
TProcList =
class(TObject)
private
FProcess: TProcess;
FCountProcs: Integer;
FOnProcListStart: TOnProcListStart;
FOnProcListFinished: TOnProcListFinished;
FOnProcRetrieve: TOnProcRetrieve;
FOnListFailure: TOnListFailure;
FOnKillFailure: TOnKillFailure;
protected
function GetProcPath(ProcID: DWORD):
string;
function GetProcID(
const Filename:
String): DWORD;
public
constructor Create;
procedure Execute;
procedure KillProc(
const Filename:
string; TimeOut: DWORD);
overload;
procedure KillProc(ID: Integer; TimeOut: DWORD);
overload;
property OnProcListStart: TOnProcListStart
read FOnProcListStart
write FOnProcListStart;
property OnProcListFinished: TOnProcListFinished
read FOnProcListFinished
write FOnProcListFinished;
property OnProcRetrieve: TOnProcRetrieve
read FOnProcRetrieve
write FOnProcRetrieve;
property OnListFailure: TOnListFailure
read FOnListFailure
write FOnListFailure;
property OnKillFailure: TOnKillFailure
read FOnKillFailure
write FOnKillFailure;
end;
implementation
{ TProcList }
constructor TProcList.Create;
begin
inherited;
FCountProcs := 0;
end;
procedure TProcList.Execute;
var
hProcSnapShot : THandle;
pe32 : TProcessEntry32;
ModuleEntry : TModuleEntry32;
FileName :
string;
begin
// make the snapshot
if Assigned(OnProcListStart)
then
FOnProcListStart(self);
hProcSnapShot := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS
or TH32CS_SNAPMODULE, 0);
if hProcSnapShot <> INVALID_HANDLE_VALUE
then
begin
pe32.dwSize := sizeof(TProcessEntry32);
ModuleEntry.dwSize := SizeOf(TModuleEntry32);
if Process32First(hProcSnapShot, pe32)
then
begin
// first process (System Process)
Inc(FCountProcs);
FProcess.ProcID := pe32.th32ProcessID;
FProcess.Filename := pe32.szExeFile;
FProcess.Priority := pe32.pcPriClassBase;
FProcess.Threads := pe32.cntThreads;
if Assigned(OnProcRetrieve)
then
FOnProcRetrieve(self, FProcess);
// walk the processes
while Process32Next(hProcSnapShot, pe32)
do
begin
FProcess.ProcID := pe32.th32ProcessID;
FileName := GetProcPath(pe32.th32ProcessID);
if FileName <> '
'
then
FProcess.Filename := FileName
else
FProcess.Filename := pe32.szExeFile;
FProcess.Priority := pe32.pcPriClassBase;
FProcess.Threads := pe32.cntThreads;
Inc(FCountProcs);
if Assigned(OnProcRetrieve)
then
FOnProcRetrieve(self, FProcess);
end;
end
else // Process32First = False
begin
if Assigned(OnListFailure)
then
FOnListFailure(self, GetLastError, SysErrorMessage(GetLastError));
CloseHandle(hProcSnapShot);
end;
end
else // hSnapShot = INVALID_HANDLE_VALUE
begin
if Assigned(OnListFailure)
then
FOnListFailure(self, GetLastError, SysErrorMessage(GetLastError));
end;
if Assigned(OnProcListFinished)
then
FOnProcListFinished(self, FCountProcs);
end;
function TProcList.GetProcPath(ProcID: DWORD):
string;
var
me32 : TModuleEntry32;
h : THandle;
s :
string;
begin
s := '
';
h := CreateToolhelp32Snapshot(TH32CS_SNAPMODULE, ProcID);
if h <> INVALID_HANDLE_VALUE
then
begin
me32.dwSize := sizeof(TModuleEntry32);
Module32First(h, me32);
s := me32.szExePath;
CloseHandle(h);
end;
result := s;
end;
function TProcList.GetProcID(
const Filename:
String): DWORD;
var
hProcSnap: THandle;
pe32: TProcessEntry32;
begin
result := 0;
hProcSnap := CreateToolHelp32SnapShot(TH32CS_SNAPPROCESS, 0);
if hProcSnap <> INVALID_HANDLE_VALUE
then
begin
pe32.dwSize := SizeOf(ProcessEntry32);
if Process32First(hProcSnap, pe32)
then
begin
while Process32Next(hProcSnap, pe32)
do
begin
if pos(AnsiLowerCase(pe32.szExeFile), AnsiLowerCase(ExtractFilename(Filename))) > 0
then
begin
result := pe32.th32ProcessID;
break;
end;
end;
end;
CloseHandle(hProcSnap);
end;
end;
procedure TProcList.KillProc(ID: Integer; TimeOut: DWORD);
var
hProcess : Cardinal;
err : DWORD;
begin
// open the process and store the process-handle
hProcess := OpenProcess(SYNCHRONIZE
or PROCESS_TERMINATE, False, ID);
// kill it
if hProcess <> 0
then
begin
err := Integer(TerminateProcess(hProcess, 1));
if err <> 0
then
begin
// TerminateProcess returns immediately, so wie have to verify the result via
// WaitForSingleObject
err := WaitForSingleObject(hProcess, TimeOut);
if err = WAIT_FAILED
then
begin
if Assigned(OnKillFailure)
then
FOnKillFailure(self, GetLastError, SysErrorMessage(GetLastError));
end;
end
else
begin
if Assigned(OnKillFailure)
then
FOnKillFailure(self, GetLastError, SysErrorMessage(GetLastError));
end;
CloseHandle(hProcess);
end
else // hProcess = INVALID_HANDLE_VALUE
begin
if Assigned(OnKillFailure)
then
FOnKillFailure(self, GetLastError, SysErrorMessage(GetLastError));
end;
end;
procedure TProcList.KillProc(
const Filename:
string; TimeOut: DWORD);
begin
KillProc(GetProcID(Filename), TimeOut);
end;