(*----------------------------------------
プロセス列挙ユニット
2010/11/24
・  SystemUnitから分離して作成

//----------------------------------------*)
unit ProcessListUnit;

interface

uses
  Types,
  Contnrs,
uses_end;

type
  TProcessItem = class
  public
    ID: DWORD;
    Name: String;
    Path: String;
//    Handle: THandle;
    ThreadCount: DWORD;
    ParentProcessID: DWORD;
    PriClassBase: Longint;
    {↓PsAPI.pas/_PROCESS_MEMORY_COUNTERSから引用}
    PageFaultCount: DWORD;              //ページフォルト
    PeakWorkingSetSize: DWORD;          //最大メモリ使用量
    WorkingSetSize: DWORD;              //メモリ使用量
    QuotaPeakPagedPoolUsage: DWORD;     //最大ページプール
    QuotaPagedPoolUsage: DWORD;         //ページプール
    QuotaPeakNonPagedPoolUsage: DWORD;  //最大非ページプール
    QuotaNonPagedPoolUsage: DWORD;      //非ページプール
    PagefileUsage: DWORD;               //ページファイル
    PeakPagefileUsage: DWORD;           //最大ページファイル

//↓データが取得できないのでコメントアウトしておく
//    dwSize: DWORD;
//    UsageCount: DWORD;
//    DefaultHeapID: DWORD;
//    ModuleID: DWORD;
//    dwFlags: DWORD;
//    ProcessHandle: THandle;
    procedure Assign(Source: TProcessItem); overload;
  end;

procedure GetProcExeNameList(Dest: TObjectList);
procedure ProcessTerminate(ProcessID: DWORD);
function GetProcessID(ExeFullPath: String): DWORD;
function GetProcessItem(ProcessID: DWORD): TProcessItem;
function ProcessExist(ExeFullPath: String): Boolean;

implementation

uses
  TLHelp32,
  PsApi,
  SysUtils,
  Windows,

  StringUnit,
  SpecialFolderPathUnit,
end_uses;

{-------------------------------
//  起動プロセスのフルパス一覧を得る関数
    GetProcExeNameList
引数説明:   Dest: Processの情報が出力されるリスト
            TProcessItemが格納される
備考:
参考:
    [Delphi:70691][Delphi:49296]
    http://msdn.microsoft.com/msdnmag/issues/02/06/debug/default.aspx
履歴:       2003/08/10
            2005/01/24
              プロセス毎のメモリ使用量(WorkingSet/Peak...)を
              求められるようにした
              参考 http://www.experts-exchange.com/Programming/Programming_Languages/Delphi/Q_20974300.html
            2005/04/05
              PageFaultCount/QuotaPagedPoolUsage/QuotaNonPagedPoolUsage/PagefileUsage
              などを取得できるようにした。
              参考 http://nienie.com/~masapico/api_sample_ps05_c.html
//--▼----------------------▽--}
{ TProcessItem }

procedure TProcessItem.Assign(Source: TProcessItem);
begin
//  if Source is TProcessItem then
  begin
    Self.ID := TProcessItem(Source).ID;
    Self.Name := TProcessItem(Source).Name;
    Self.Path := TProcessItem(Source).Path;
//    Self.Handle := TProcessItem(Source).Handle;
    Self.ThreadCount := TProcessItem(Source).ThreadCount;
    Self.ParentProcessID := TProcessItem(Source).ParentProcessID;
    Self.PriClassBase := TProcessItem(Source).PriClassBase;

    Self.PageFaultCount := TProcessItem(Source).PageFaultCount;
    Self.WorkingSetSize := TProcessItem(Source).WorkingSetSize;
    Self.PeakWorkingSetSize := TProcessItem(Source).PeakWorkingSetSize;
    Self.QuotaPeakPagedPoolUsage := TProcessItem(Source).QuotaPeakNonPagedPoolUsage;
    Self.QuotaPagedPoolUsage := TProcessItem(Source).QuotaPagedPoolUsage;
    Self.QuotaPeakNonPagedPoolUsage := TProcessItem(Source).QuotaPeakNonPagedPoolUsage;
    Self.QuotaNonPagedPoolUsage := TProcessItem(Source).QuotaNonPagedPoolUsage;
    Self.PagefileUsage := TProcessItem(Source).PagefileUsage;
    Self.PeakPagefileUsage := TProcessItem(Source).PeakPagefileUsage;
  end;
end;


{ -----------------------------------
変なパス名を変換する関数
参考:http://msdn.microsoft.com/msdnmag/issues/02/06/debug/default.aspx
このページのdebug.exeを解凍して現れる
.\debug\Common\Helpers.cpp の
void TranslateFilename(LPCTSTR szFilename, LPTSTR szWin32Name)
の機能と同じ
//----------------------------------- }
function TranslateFilename(SourceFileName: String): String;
begin
  Result := SourceFileName;
  Result := StringReplace(Result, '\SystemRoot', WindowsFolderPath, []);
  Result := StringReplace(Result, '\??\', '', []);
end;

procedure GetProcExeNameList(Dest: TObjectList);
var
  hProcessSnapshot: THandle;
  ProcessEntry: TProcessEntry32;
  PID: DWORD;
  ProcessStatus: Boolean;
  hProcess: THandle;
  ModuleFileName: array[0..MAX_PATH] of Char;
  Item: TProcessItem;
  psmemCounters: _PROCESS_MEMORY_COUNTERS;
  i: Integer;
  OwnsObjBuffer: Boolean;
begin
  OwnsObjBuffer := Dest.OwnsObjects;
  Dest.OwnsObjects := False;
  for i := Dest.Count-1 downto 0 do
  begin
    Item := TProcessItem(Dest.Items[i]);
    FreeAndNil(Item);
    Dest.Delete(i);
  end;
  Dest.OwnsObjects := OwnsObjBuffer;

  hProcessSnapshot := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0);
  if hProcessSnapshot <> $FFFFFFFF then
  begin
    try {↓プロセスを列挙してループ}
      ProcessEntry.dwSize := sizeof(TProcessEntry32);
      ProcessStatus := Process32First(hProcessSnapshot, ProcessEntry);
      while ProcessStatus do
      begin
        PID := ProcessEntry.th32ProcessID;

        hProcess := OpenProcess(PROCESS_QUERY_INFORMATION or PROCESS_VM_READ, False, PID);
        if hProcess <> 0 then
        try {↓プロセスのファイルパスを取得}

          Item := TProcessItem.Create;
          Item.ID := PID;
          //Item.ID := ProcessEntry.th32ProcessID;
          Item.Name := ProcessEntry.szExeFile;
//          Item.Handle := hProcess;

          if GetModuleFileNameEx(hProcess, 0, ModuleFileName, Sizeof(ModuleFileName)) = 0 then
          begin
            Item.Path := '[System]';
          end else
          begin
            Item.Path := TranslateFilename(ModuleFileName);
          end;

          Item.ThreadCount := ProcessEntry.cntThreads;
          Item.ParentProcessID := ProcessEntry.th32ParentProcessID;
          Item.PriClassBase := ProcessEntry.pcPriClassBase;

          psmemCounters.cb:=SizeOf(_PROCESS_MEMORY_COUNTERS);
          if GetProcessMemoryInfo(hProcess, @psmemCounters, SizeOf(_PROCESS_MEMORY_COUNTERS)) then
          begin
            Item.PageFaultCount := psmemCounters.PageFaultCount;
            Item.WorkingSetSize := psmemCounters.WorkingSetSize;
            Item.PeakWorkingSetSize := psmemCounters.PeakWorkingSetSize;
            Item.QuotaPeakPagedPoolUsage := psmemCounters.QuotaPeakNonPagedPoolUsage;
            Item.QuotaPagedPoolUsage := psmemCounters.QuotaPagedPoolUsage;
            Item.QuotaPeakNonPagedPoolUsage := psmemCounters.QuotaPeakNonPagedPoolUsage;
            Item.QuotaNonPagedPoolUsage := psmemCounters.QuotaNonPagedPoolUsage;
            Item.PagefileUsage := psmemCounters.PagefileUsage;
            Item.PeakPagefileUsage := psmemCounters.PeakPagefileUsage;
          end else
          begin
            Item.PageFaultCount := 0;
            Item.WorkingSetSize := 0;
            Item.PeakWorkingSetSize := 0;
            Item.QuotaPeakPagedPoolUsage := 0;
            Item.QuotaPagedPoolUsage := 0;
            Item.QuotaPeakNonPagedPoolUsage := 0;
            Item.QuotaNonPagedPoolUsage := 0;
            Item.PagefileUsage := 0;
            Item.PeakPagefileUsage := 0;
          end;

          Dest.Add(Item);
        finally
          CloseHandle(hProcess);
        end;
        ProcessStatus := Process32Next(hProcessSnapshot, ProcessEntry)
      end

    finally
      CloseHandle(hProcessSnapshot);
    end;
  end else
    raise Exception.Create(SysErrorMessage(GetLastError));
end;
//--△----------------------▲--

{-------------------------------
//  プロセスを強制終了する関数
    ProcessTerminate
引数説明:   ProcessID:停止したいプロセスIDを指定する
備考:
参考:
        [Delphi:47838] Re: プログラムを強制終了する方法
履歴:       2005/03/30 作成
//--▼----------------------▽--}
procedure ProcessTerminate(ProcessID: DWORD);
var
  hProcess: THandle;
begin
  {↓プロセス強制終了}
  hProcess := OpenProcess(PROCESS_TERMINATE, False, ProcessID);
  TerminateProcess(hProcess , 0 );
  CloseHandle(hProcess);
end;
//--△----------------------▲--

{-------------------------------
//  ExeのパスからProcessIDを求める関数
備考:       プロセスが無い場合は0が返る
            複数のProcessがある場合でも先に見つかった
            ProcessIDを返す
履歴:       2005/10/12
            2006/12/21(木) ファイル名をSameFile関数で比較することにした
//--▼----------------------▽--}
function GetProcessID(ExeFullPath: String): Cardinal;
var
  i: Integer;
  ProcessList: TObjectList;
begin
  Result := 0;
  {↓プロセス終了コード}
  ProcessList := TObjectList.Create;
  try
    GetProcExeNameList(ProcessList);
    for i := 0 to ProcessList.Count - 1 do
    begin
      if SameFileName(TProcessItem(ProcessList.Items[i]).Path, ExeFullPath) then
      begin
        Result := TProcessItem(ProcessList.Items[i]).ID;
        break;
      end;
    end;
  finally
    ProcessList.Free;
  end;
end;
//--△----------------------▲--

{-------------------------------
//  ProcessIDからProcessItemを求める関数
備考:       プロセスが無い場合はnilが返る
履歴:       2007/12/14
//--▼----------------------▽--}
function GetProcessItem(ProcessID: DWORD): TProcessItem;
var
  i: Integer;
  ProcessList: TObjectList;
begin
  Result := nil;
  {↓プロセス終了コード}
  ProcessList := TObjectList.Create;
  try
    GetProcExeNameList(ProcessList);
    for i := 0 to ProcessList.Count - 1 do
    begin
      if TProcessItem(ProcessList.Items[i]).ID = ProcessID then
      begin
        Result := TProcessItem(ProcessList.Items[i]);
		ProcessList.Extract(ProcessList.Items[i]);
        break;
      end;
    end;
  finally
    ProcessList.Free;
  end;
end;
//--△----------------------▲--

{-------------------------------
//  ExeのパスからProcessの存在をみつける関数
機能:       GetProcessIDをそのまま利用
備考:
この関数を利用して次のような記述が可能
    var Timer: TDateTime;
      //↓プロセスが起動している間、待つ関数
      Timer := Now;
      while ProcessExist('C:\WINDOWS\system32\notepad.exe') do
      begin
        Application.ProcessMessages;
        if 10<=SecondSpan(Now, Timer) then Exit;
        //↑ループが10秒以上経過したら関数を抜ける処理
      end;
履歴:       2006/12/21(木) 12:01
//--▼----------------------▽--}
function ProcessExist(ExeFullPath: String): Boolean;
begin
  if GetProcessID(ExeFullPath) = 0 then
  begin
    Result := False;
  end else
  begin
    Result := True;
  end;
end;
//--△----------------------▲--

end.