Delphi World - Unit с полезными функциями для работы с процессами
Delphi World - это проект, являющийся сборником статей и малодокументированных возможностей  по программированию в среде Delphi. Здесь вы найдёте работы по следующим категориям: delphi, delfi, borland, bds, дельфи, делфи, дэльфи, дэлфи, programming, example, программирование, исходные коды, code, исходники, source, sources, сорцы, сорсы, soft, programs, программы, and, how, delphiworld, базы данных, графика, игры, интернет, сети, компоненты, классы, мультимедиа, ос, железо, программа, интерфейс, рабочий стол, синтаксис, технологии, файловая система...
Unit с полезными функциями для работы с процессами

Автор: 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;
Проект Delphi World © Выпуск 2002 - 2017
Автор проекта: Эксклюзивные курсы программирования