Автор: Alex Kantchev
WEB-сайт: http://delphibase.endimus.com

{ **** UBPFD *********** by delphibase.endimus.com ****
>> Unit с полезными функциями для работы с процессами

Этот Unit содержит полезные функции для работы с процессами.
Взять информацию о данном процессе, обо всех процессах, убить процесс, и т.д.
Полезна при создании системных приложений под Win32.
Надо хорошо оттестировать этот Unit.

Зависимости: windows, PSAPI, TlHelp32, SysUtils;
Автор:       Alex Kantchev, stoma@bitex.bg
Copyright:   Моя разработка, некоторые функции базируются
             на примере в MSDN jan 2000 Collection
Дата:        5 июня 2002 г.
***************************************************** }

unit ProcUtilz;

interface
uses windows, PSAPI, TlHelp32, SysUtils;

type
  TLpModuleInfo = packed record
    ModuleInfo: LPMODULEINFO;
    ModulePID: Cardinal;
    ModuleName: string;
  end;

type
  TLpModuleInfoArray = array of TLpModuleInfo;

function RegisterServiceProcess(dwProcessID, dwType: Integer): Integer; stdcall;
external 'KERNEL32.DLL';
function DisplayProcessInThreeFingerSalute(PID: Integer; Disp: Boolean):
  Boolean;
function TakeProcessID(WindowTitle: string): Integer;
function GetCurrAppPID: Integer;
function GetAllProcessesInfo(ExtractFullPath: Boolean = false):
  TLpModuleInfoArray;
function ExtractExeFromModName(ModuleName: string): string;
function TerminateTask(PID: integer): integer;

implementation

//Wziat PID na danoi process ot nego window title

function TakeProcessID(WindowTitle: string): Integer;
var
  WH: THandle;
begin
  result := 0;
  WH := FindWindow(nil, pchar(WindowTitle));
  if WH <> 0 then
    GetWindowThreadProcessID(WH, @Result);
end;

//Wziat PID na tekuchii process

function GetCurrAppPID: Integer;
begin
  GetCurrAppPID := GetCurrentProcessID;
end;

//Pokzat process s PID v task menagera Windows 9X
//WNIMANIE: Rabotaet tolko pod Win9x !!!!

function DisplayProcessInThreeFingerSalute(PID: Integer; Disp: Boolean):
  Boolean;
begin
  result := false;
  if Win32Platform = VER_PLATFORM_WIN32_WINDOWS then
  begin
    try
      if Disp = True then
        RegisterServiceProcess(PID, 0)
      else
        RegisterServiceProcess(PID, 1);
    except
      result := false;
    end;
  end;
  DisplayProcessInThreeFingerSalute := result;
end;

//Ostanavlivaet rabotu procesa. Ne rabotaet so WinNT
//serviznae processi.

function TerminateTask(PID: integer): integer;
var
  process_handle: integer;
  lpExitCode: Cardinal;
begin
  process_handle := openprocess(PROCESS_ALL_ACCESS, true, pid);
  GetExitCodeProcess(process_handle, lpExitCode);
  if (process_handle = 0) then
    TerminateTask := GetLastError
  else if terminateprocess(process_handle, lpExitCode) then
  begin
    TerminateTask := 0;
    CloseHandle(process_handle);
  end
  else
  begin
    TerminateTask := GetLastError;
    CloseHandle(process_handle);
  end;
end;

//Wziat informacia ob processse po ego PID
//Testirano pod WinNT.

function GetProcessInfo(PID: WORD): LPMODULEINFO;
var
  RetVal: LPMODULEINFO;
  hProc: DWORD;
  hMod: HMODULE;
  cm: cardinal;
begin
  hProc := OpenProcess(PROCESS_QUERY_INFORMATION or PROCESS_VM_READ, false,
    PID);
  GetMem(RetVal, sizeOf(LPMODULEINFO));
  if not (hProc = 0) then
  begin
    EnumProcessModules(hProc, @hMod, 4, cm);
    GetModuleInformation(hProc, hMod, RetVal, SizeOf(RetVal));
  end;
  GetProcessInfo := RetVal;
end;

//Wziat executable processa ot ego polnai put

function ExtractExeFromModName(ModuleName: string): string;
begin
  ExtractExeFromModName := Copy(ModuleName, LastDelimiter('\', ModuleName) + 1,
    Length(ModuleName));
  ;
end;

//Wziat informacia ob wse processi rabotaushtie w tekuchii
//moment. Testirano pod WinNT

function GetAllProcessesInfo(ExtractFullPath: Boolean = false):
  TLpModuleInfoArray;
var
  ProcList: array[0..$FFF] of DWORD;
  RetVal: TLpModuleInfoArray;
  ProcCnt: Cardinal;
  I, MaxCnt: WORD;
  ModName: array[0..max_path] of char;
  ph, mh: THandle;
  cm: Cardinal;
  SnapShot: THandle;
  ProcEntry: TProcessEntry32;
  RetValLength, CVal: WORD;
  ModInfo: LPMODULEINFO;
begin
  //case the platform is Win9X
  if Win32Platform = VER_PLATFORM_WIN32_WINDOWS then
  begin
    GetMem(ModInfo, SizeOf(LPMODULEINFO));
    SnapShot := CreateToolhelp32Snapshot(th32cs_snapprocess, 0);
    RetValLength := 0;
    CVal := 0;
    if not integer(SnapShot) = -1 then
    begin
      ProcEntry.dwSize := sizeof(TProcessEntry32);
      if Process32First(SnapShot, ProcEntry) then
        repeat
          //get the size of out array
          Inc(RetValLength);
        until not Process32Next(SnapShot, ProcEntry);
      //set the size of the output array
      SetLength(RetVal, RetValLength);
      //iterate through processes and get their info
      if Process32First(SnapShot, ProcEntry) then
        repeat
          begin
            Inc(CVal);
            ModInfo.lpBaseOfDll := nil;
            ModInfo.SizeOfImage := ProcEntry.dwSize;
            ModInfo.EntryPoint := nil;
            RetVal[CVal].ModuleInfo := ModInfo;
            RetVal[CVal].ModulePID := ProcEntry.th32ProcessID;
            if (ExtractFullPath) then
              RetVal[CVal].ModuleName := string(ProcEntry.szExeFile)
            else
              RetVal[CVal].ModuleName :=
                ExtractExeFromModName(string(ProcEntry.szExeFile));
            ModInfo := nil;
          end;
        until not Process32Next(SnapShot, ProcEntry);
    end;
  end
    //case the platform is WinNT/2K/XP
  else
  begin
    EnumProcesses(@ProcList, sizeof(ProcList), ProcCnt);
    MaxCnt := ProcCnt div 4;
    SetLength(RetVal, MaxCnt);
    //iterate through processes and get their info
    for i := Low(RetVal) to High(RetVal) do
    begin
      //Check for reserved PIDs
      if ProcList[i] = 0 then
      begin
        RetVal[i].ModuleName := 'System Idle Process';
        RetVal[i].ModulePID := 0;
        RetVal[i].ModuleInfo := ProcUtilz.GetProcessInfo(i);
      end
      else if ProcList[i] = 8 then
      begin
        RetVal[i].ModuleName := 'System';
        RetVal[i].ModulePID := 8;
        RetVal[i].ModuleInfo := ProcUtilz.GetProcessInfo(i);
      end
        //Gather info about all processes
      else
      begin
        RetVal[i].ModulePID := ProcList[i];
        RetVal[i].ModuleInfo := GetProcessInfo(ProcList[i]);
        //get module name
        ph := OpenProcess(PROCESS_QUERY_INFORMATION or PROCESS_VM_READ, false,
          ProcList[i]);
        if ph > 0 then
        begin
          EnumProcessModules(ph, @mh, 4, cm);
          GetModuleFileNameEx(ph, mh, ModName, sizeof(ModName));
          if (ExtractFullPath) then
            RetVal[i].ModuleName := string(ModName)
          else
            RetVal[i].ModuleName := ExtractExeFromModName(string(ModName));
        end
        else
          RetVal[i].ModuleName := 'UNKNOWN';
        CloseHandle(ph);
      end;
    end;
  end;
  //return the array of LPMODULEINFO structz
  GetAllProcessesInfo := RetVal;
end;

end.

Пример использования:

procedure TForm1.Button1Click(Sender: TObject);
var
  I: Integer;
  PC: WORD;
begin
  ListBox1.Clear;
  ProcArr := TLpModuleInfoArray(ProcUtilz.GetAllProcessesInfo);
  PC := 0;
  for i := Low(ProcArr) to High(ProcArr) do
  begin
    ListBox1.Items.Add('Process Name: ' + ProcArr[i].ModuleName +
      ' : Proccess ID ' + IntToStr(ProcArr[i].ModulePID) + ' : Image Size: ' +
      IntToStr(ProcArr[i].ModuleInfo.SizeOfImage));
    Inc(PC);
  end;
  ListBox1.Items.Add('Total process count: ' + IntToStr(PC));
end;

procedure TForm1.Button2Click(Sender: TObject);
var
  EC: Integer;
begin
  EC := ProcUtilz.TerminateTask(ProcArr[ListBox1.ItemIndex].ModulePID);
  if EC = 0 then
    MessageDlg('Task terminated successfully!', mtInformation, [mbOK], 0)
  else
    MessageDlg('Unable to terminate task! GetLastError() returned: ' +
      IntToStr(EC), mtWarning, [mbOK], 0);
  Button1Click(Sender);
end;