Monitoring processes with Delphi

The other day we were interested on listing the threads of a process with one of my colleagues. We started looking for some information on the internet and ended in a very interesting application from sourceforge. Before continuing, I've made several changes into the blog in order to gain more exposure. I've added the Feedjit widgets to show the list of trafic feed and page popularity and I've also added two more buttons showing my profile into delicious and flickr. And I've truncated the post to gain load pages and bandwidth.

Well, going on in our topic, I've managed to release a little application that shows all the processes and the threads on every process. It's a simple approximation, but it helps to understand how works the API by Using the CreateToolhelp32Snapshot function where we can point the list of process and go to each of them and gather their properties. For the threads, we can use the same function but using the threads functions to cover all of them.

I've got some of information from Experts-exchange and I found a little example from madshi and I've made some modifications and I've adapted the methods for my own intentions.
Here you can get the source code modified:

unit processMonitor;

interface

uses
   Contnrs, Windows;

type
   TExeType = (etUnknown, etDos, etWin16, etConsole, etWin32);

   TWindowList = array of record
       pid: cardinal;
       tid: cardinal;
       window: cardinal;
       parent: cardinal;
       owner: cardinal;
       visible: boolean;
       enabled: boolean;
       inTaskbar: boolean;
       rect: TRect;
       title: string;
       className: string;
   end;

   TThread = class(TObject)
   private
       Fwindows: TWindowList;
       FpId: cardinal;
       FtId: cardinal;
       procedure SetpId(const Value: cardinal);
       procedure SettId(const Value: cardinal);
       procedure Setwindows(const Value: TWindowList);
   public
       property pId: cardinal read FpId write SetpId;
       property tId: cardinal read FtId write SettId;
       property windows: TWindowList read Fwindows write Setwindows;
       function Clone() : TThread;
   end;

   TThreadList = class(TObjectList)
   protected
       function GetItem(Index: Integer): TThread; overload;
       procedure SetItem(Index: Integer; AObject: TThread);
   public
       property Items[Index: Integer]: TThread read GetItem write SetItem; default;
   end;

   TProcess = class(TObject)
   private
       Fname: string;
       FexeType: TExeType;
       Fpid: cardinal;
       Fthreads: TThreadList;
       procedure SetexeType(const Value: TExeType);
       procedure Setname(const Value: string);
       procedure Setpid(const Value: cardinal);
       procedure Setthreads(const Value: TThreadList);
   public
       property pid: cardinal read Fpid write Setpid;
       property name: string read Fname write Setname;
       property exeType: TExeType read FexeType write SetexeType;
       property threads: TThreadList read Fthreads write Setthreads;
       constructor Create();
       destructor Destroy(); override;
   end;

   TProcessList = class(TObjectList)
   protected
       function GetItem(Index: Integer): TProcess; overload;
       procedure SetItem(Index: Integer; AObject: TProcess);
   public
       property Items[Index: Integer]: TProcess read GetItem write SetItem; default;
   end;

   TProcessMonitor = class(TObject)
   private
       FListOfProcess: TProcessList;
       FListOfThreads: TThreadList;
       procedure SetListOfProcess(const Value: TProcessList);
       procedure SetListOfThreads(const Value: TThreadList);
   public
       property ListOfProcess: TProcessList read FListOfProcess write SetListOfProcess;
       property ListOfThreads: TThreadList read FListOfThreads write SetListOfThreads;
       procedure FillListOfProcess();
       procedure FillListOfThreads();
       constructor Create();
       destructor Destroy(); override;
   end;

type
   TACardinal = array[0..maxInt shr 2 - 1] of cardinal;
   TPACardinal = ^TACardinal;
   TDACardinal = array of cardinal;

const
   MAX_MODULE_NAME32 = 255;
   TH32CS_SnapProcess = 2;
   TH32CS_SnapThread = 4;
   TH32CS_SnapModule = 8;
type
   TProcessEntry32 = record
       dwSize: DWORD;
       cntUsage: DWORD;
       th32ProcessID: DWORD;
       th32DefaultHeapID: DWORD;
       th32ModuleID: DWORD;
       cntThreads: DWORD;
       th32ParentProcessID: DWORD;
       pcPriClassBase: integer;
       dwFlags: DWORD;
       szExeFile: array[0..MAX_PATH - 1] of char;
   end;
   TThreadEntry32 = record
       dwSize: DWORD;
       cntUsage: DWORD;
       th32ThreadID: DWORD;
       th32OwnerProcessID: DWORD;
       tpBasePri: integer;
       tpDeltaPri: integer;
       dwFlags: DWORD;
   end;
   TModuleEntry32 = record
       dwSize: DWORD;
       th32ModuleID: DWORD;
       th32ProcessID: DWORD;
       GlblcntUsage: DWORD;
       ProccntUsage: DWORD;
       modBaseAddr: pointer;
       modBaseSize: DWORD;
       hModule: HMODULE;
       szModule: array[0..MAX_MODULE_NAME32] of char;
       szExePath: array[0..MAX_PATH - 1] of char;
   end;

implementation

uses
   SysUtils, ShellAPI;

var
   CreateToolhelp32Snapshot: function(dwFlags, th32ProcessID: cardinal): cardinal; stdcall = nil;
   Process32First: function(hSnapshot: cardinal; var lppe: TProcessEntry32): bool; stdcall = nil;
   Process32Next: function(hSnapshot: cardinal; var lppe: TProcessEntry32): bool; stdcall = nil;
   Thread32First: function(hSnapshot: cardinal; var lpte: TThreadEntry32): bool; stdcall = nil;
   Thread32Next: function(hSnapshot: cardinal; var lpte: TThreadEntry32): bool; stdcall = nil;
   Module32First: function(hSnapshot: cardinal; var lpme: TModuleEntry32): bool; stdcall = nil;
   Module32Next: function(hSnapshot: cardinal; var lpme: TModuleEntry32): bool; stdcall = nil;
   EnumProcesses: function(idProcess: TPACardinal; cb: cardinal; var cbNeeded: cardinal): bool; stdcall = nil;
   EnumProcessModules: function(hProcess: cardinal; var hModule: cardinal; cb: cardinal; var cbNeeded: cardinal): bool; stdcall = nil;
   GetModuleFileNameEx: function(hProcess, hModule: cardinal; fileName: PChar; nSize: cardinal): cardinal; stdcall = nil;
   ew_pid, ew_tid: cardinal;
   ew_onlyThoseInTaskbar: boolean;

function NextFunctions: boolean;
var
   c1: cardinal;
begin
   c1 := GetModuleHandle(kernel32);
   @CreateToolhelp32Snapshot := GetProcAddress(c1, 'CreateToolhelp32Snapshot');
   @Process32First := GetProcAddress(c1, 'Process32First');
   @Process32Next := GetProcAddress(c1, 'Process32Next');
   @Thread32First := GetProcAddress(c1, 'Thread32First');
   @Thread32Next := GetProcAddress(c1, 'Thread32Next');
   @Module32First := GetProcAddress(c1, 'Module32First');
   @Module32Next := GetProcAddress(c1, 'Module32Next');
   result := (@CreateToolhelp32Snapshot <> nil) and
       (@Process32First <> nil) and (@Process32Next <> nil) and
       (@Thread32First <> nil) and (@Thread32Next <> nil) and
       (@Module32First <> nil) and (@Module32Next <> nil);
end;

function GetExeType(exefile: string): TExeType;
var
   c1: cardinal;
   sfi: TSHFileInfo;
   s1: string;
begin
   c1 := SHGetFileInfo(pchar(exefile), 0, sfi, SizeOf(sfi), SHGFI_EXETYPE);
   s1 := chr(c1 and $FF) + chr((c1 and $FF00) shr 8);
   if s1 = 'MZ' then
       result := etDos
   else if s1 = 'NE' then
       result := etWin16
   else if (s1 = 'PE') and (hiWord(c1) = 0) then
       result := etConsole
   else if (s1 = 'PE') and (hiWord(c1) > 0) then
       result := etWin32
   else if CompareText(AnsiUpperCase(ExtractFileName(exefile)), AnsiUpperCase('winoa386.mod')) = 0 then
       result := etDos
   else
       result := etUnknown;
end;

{ TThread }

function TThread.Clone: TThread;
var
   res : TThread;
begin
   res := TThread.Create;
   res.FpId := Self.FpId;
   res.FtId := Self.FtId;
   res.Fwindows := Self.Fwindows;
   result := res;
end;

procedure TThread.SetpId(const Value: cardinal);
begin
   FpId := Value;
end;

procedure TThread.SettId(const Value: cardinal);
begin
   FtId := Value;
end;

procedure TThread.Setwindows(const Value: TWindowList);
begin
   Fwindows := Value;
end;

{ TThreadList }

function TThreadList.GetItem(Index: Integer): TThread;
begin
   Result := TThread(inherited Items[Index]);
end;

procedure TThreadList.SetItem(Index: Integer; AObject: TThread);
begin
   inherited Items[Index] := AObject;
end;

{ TProcess }

constructor TProcess.Create;
begin
   Fthreads := TThreadList.Create;
end;

destructor TProcess.Destroy;
begin
   FreeAndNil(Fthreads);
   inherited;
end;

procedure TProcess.SetexeType(const Value: TExeType);
begin
   FexeType := Value;
end;

procedure TProcess.Setname(const Value: string);
begin
   Fname := Value;
end;

procedure TProcess.Setpid(const Value: cardinal);
begin
   Fpid := Value;
end;

procedure TProcess.Setthreads(const Value: TThreadList);
begin
   Fthreads := Value;
end;

{ TProcessMonitor }

constructor TProcessMonitor.Create;
begin
   FListOfProcess := TProcessList.Create();
   FListOfThreads := TThreadList.Create();
   FillListOfProcess();
end;

destructor TProcessMonitor.Destroy;
begin
   FreeAndNil(FListOfProcess);
   FreeAndNil(FListOfThreads);
   inherited;
end;

procedure TProcessMonitor.FillListOfProcess;
var
   c1: cardinal;
   pe: TProcessEntry32;
   process: TProcess;
   i1, i2: Integer;
begin
   if not NextFunctions then exit;
   c1 := CreateToolHelp32Snapshot(TH32CS_SnapProcess, 0);
   try
       pe.dwSize := sizeOf(pe);
       if Process32First(c1, pe) then
           repeat
               process := TProcess.Create;
               process.pid := pe.th32ProcessID;
               process.name := pe.szExeFile;
               process.exeType := GetExeType(process.name);
               FListOfProcess.Add(process);
           until not Process32Next(c1, pe);
   finally
       CloseHandle(c1)
   end;
   FillListOfThreads();

   for i1 := 0 to FListOfThreads.count - 1 do
       for i2 := 0 to FListOfProcess.count - 1 do
           if FListOfThreads[i1].pid = FListOfProcess[i2].pid then
           begin
               FListOfProcess[i2].threads.Add(FListOfThreads[i1].clone);
           end;
end;

procedure TProcessMonitor.FillListOfThreads;
   function EnumWindowsProc(hwnd: cardinal; lParam: integer): LongBool; stdcall;
   var
       pwl: ^TWindowList;
       i1: integer;
       cpid, ctid: cardinal;
       cpar, cown: cardinal;
       bvis, btsk: boolean;
   begin
       result := true;
       ctid := GetWindowThreadProcessID(hwnd, @cpid);
       if ((ew_pid = 0) or (ew_pid = cpid)) and ((ew_tid = 0) or (ew_tid = ctid)) then
       begin
           bvis := IsWindowVisible(hwnd);
           cown := GetWindow(hwnd, GW_OWNER);
           cpar := GetParent(hwnd);
           btsk := (cown = 0) and (cpar = 0) and bvis and (GetWindowLong(hwnd, GWL_EXSTYLE) and WS_EX_TOOLWINDOW = 0);
           if (not ew_onlyThoseInTaskbar) or btsk then
           begin
               pwl := pointer(lParam);
               i1 := length(pwl^);
               SetLength(pwl^, i1 + 1);
               with pwl^[i1] do
               begin
                   window := hwnd;
                   parent := cpar;
                   owner := cown;
                   visible := bvis;
                   enabled := IsWindowEnabled(hwnd);
                   inTaskbar := btsk;
                   GetWindowRect(hwnd, rect);
                   SetLength(title, MAX_PATH);
                   SetLength(title, GetWindowText(hwnd, pchar(title), MAX_PATH));
                   SetLength(className, MAX_PATH);
                   SetLength(className, GetClassName(hwnd, pchar(className), MAX_PATH));
                   pid := cpid;
                   tid := ctid;
               end;
           end;
       end;
   end;
   function GetWindowList(pid: cardinal = 0; tid: cardinal = 0; onlyThoseInTaskbar: boolean = false): TWindowList;
   begin
       result := nil;
       ew_pid := pid;
       ew_tid := tid;
       ew_onlyThoseInTaskbar := onlyThoseInTaskbar;
       if ew_tid = 0 then
           EnumWindows(@EnumWindowsProc, integer(@result))
       else
           EnumThreadWindows(ew_tid, @EnumWindowsProc, integer(@result));
   end;
var
   c1: cardinal;
   i1: integer;
   te: TThreadEntry32;
   thread: TThread;
begin
   if not NextFunctions then exit;
   c1 := CreateToolHelp32Snapshot(TH32CS_SnapThread, 0);
   try
       te.dwSize := sizeOf(te);
       if Thread32First(c1, te) then
           repeat
               thread := TThread.Create();
               thread.tId := te.th32ThreadID;
               thread.pId := te.th32OwnerProcessID;
               FListOfThreads.Add(thread);
           until not Thread32Next(c1, te);
   finally
       CloseHandle(c1)
   end;
   for i1 := 0 to FListOfThreads.Count - 1 do
       if (FListOfThreads[i1].pid <> 0) then
           FListOfThreads[i1].windows := GetWindowList(FListOfThreads[i1].pid, FListOfThreads[i1].tid);
end;

procedure TProcessMonitor.SetListOfProcess(const Value: TProcessList);
begin
   FListOfProcess := Value;
end;

procedure TProcessMonitor.SetListOfThreads(const Value: TThreadList);
begin
   FListOfThreads := Value;
end;

{ TProcessList }

function TProcessList.GetItem(Index: Integer): TProcess;
begin
   Result := TProcess(inherited Items[Index]);
end;

procedure TProcessList.SetItem(Index: Integer; AObject: TProcess);
begin
   inherited Items[Index] := AObject;
end;

end.

The example of creating the object TProcessMonitor is the following:

var
   processMonitor : TProcessMonitor;

implementation

procedure TFMain.Button1Click(Sender: TObject);
var
   i : Integer;
begin
   if Assigned(processMonitor) then
       FreeAndNil(processMonitor);

   processMonitor := TProcessMonitor.Create();
   for i := 0 to processMonitor.ListOfProcess.Count - 1 do
       ListBox1.AddItem('pid: ' + IntToStr(processMonitor.ListOfProcess[i].pid)
           + ' appName: ' + processMonitor.ListOfProcess[i].name
           + ' number of Threads: ' + Inttostr(processMonitor.ListOfProcess[i].threads.count-1),
           processMonitor.ListOfProcess[i].threads);
end;

procedure TFMain.FormDestroy(Sender: TObject);
begin
   FreeAndNil(processMonitor);
end;

procedure TFMain.ListBox1DblClick(Sender: TObject);
var
   t : TThreadList;
   i, j : integer;
begin
   if ListBox1.Items.Count <>0 then
   begin
       Memo2.clear;
       Memo1.clear;
       t := TThreadList(ListBox1.Items.Objects[ListBox1.ItemIndex]);
       for i := 0 to t.Count -1 do
       begin
           memo2.Lines.Add('pid: ' + IntToStr(t[i].tId));
           for j := 0 to Length(t[i].windows)-1 do
           begin
               Memo1.lines.Add('pid: ' + IntToStr(t[i].windows[j].pid)
                   + ' tid: ' + IntToStr(t[i].windows[j].tid)
                   + ' window: ' + IntToStr(t[i].windows[j].window)
                   + ' parent: ' + IntToStr(t[i].windows[j].parent)
                   + ' owner: ' + IntToStr(t[i].windows[j].owner)
                   + ' title: ' + t[i].windows[j].title
                   + ' className: ' + t[i].windows[j].className);
           end;
       end;
   end;
end;

And the execution of the program:


Interesting applications that I've found (Open Source) are asmProfiler and YAPM (Yet another Process Monitor). All of them amazing, and I recommend to visit their pages and downloading the latest version.