1:

function TSysProc.ProcInfoByID(ID: DWORD; OUT Pfad:string): TProcessRecord;					

1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:

function ShowModulePath(PID: cardinal): string;
var modsnap : Thandle;
    MODULES : TModuleEntry32;
begin (*MODULES*)
 MODULES.dwSize:= sizeof(TMOduleEntry32);
 modsnap:= CreateToolhelp32Snapshot(TH32CS_SNAPMODULE, PID);
 if Module32First(modsnap, MODULES) then
   result:= MODULES.szExePath;
 CloseHandle(modsnap);
end;


procedure TSysProc.ProcCompare;
..
begin
..
  for I := 0 to High(FDetailsAllprocs) do begin
    s:= ShowModulePath(FDetailsAllprocs[I].ProcID);    
    memo4.Lines.Add(s);
  end;
...
end;					

1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:
26:
27:
28:
29:
30:
31:
32:
33:
34:
35:
36:
37:
38:
39:
40:
41:
42:
43:
44:
45:
46:
47:
48:
49:
50:
51:
52:
53:
54:
55:
56:
57:
58:
59:
60:
61:
62:
63:
64:
65:
66:
67:
68:
69:
70:
71:
72:
73:
74:
75:
76:
77:
78:
79:
80:
81:
82:
83:
84:
85:
86:
87:
88:
89:
90:
91:
92:
93:
94:
95:
96:
97:
98:
99:
100:
101:
102:
103:
104:
105:
106:
107:
108:
109:
110:
111:
112:
113:
114:
115:
116:
117:
118:
119:
120:
121:
122:
123:
124:
125:
126:
127:
128:
129:
130:
131:
132:
133:
134:
135:
136:
137:
138:
139:
140:
141:
142:
143:
144:
145:
146:
147:
148:
149:
150:
151:
152:
153:
154:
155:
156:
157:
158:
159:
160:
161:
162:
163:
164:
165:
166:
167:
168:
169:
170:
171:
172:
173:
174:
175:
176:
177:
178:
179:
180:
181:
182:
183:
184:
185:
186:
187:
188:
189:
190:
191:
192:
193:
194:
195:
196:
197:
198:
199:
200:
201:
202:
203:
204:
205:
206:
207:
208:
209:
210:
211:
212:
213:
214:
215:
216:
217:
218:
219:
220:
221:
222:
223:
224:
225:
226:
227:
228:
229:
230:
231:
232:
233:
234:
235:
236:
237:
238:
239:
240:
241:
242:
243:
244:
245:
246:
247:
248:
249:
250:
251:
252:

unit Unit1;
{
Author: Benjamin Loschke
Date:   24.01.2007
Zweck:  Dieses Programm ermittelt die momentan auf dem System
        laufenden Prozesse und ermittelt die Cpu-Auslastung
        eines jeden Prozesses. Es zeigt nur die Prozesse an
        die eine Auslastung von über 0% besitzen oder es vor
        bis zu 10 Refreshzyklen hatten.
Update: 25.01.2007
        Programm unterstützt nun das ausfiltern von gewissen Programmen.
        ListBox wird jetzt als MulticolumnListbox angezeigt.
        Trackbar eingebettet, mit dem man die Refreshzeiten einstellen kann.
}
interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, tlhelp32,processinfo, ExtCtrls, ComCtrls;


type
  TForm1 = class(TForm)
    ListBox1: TListBox;
    Timer1: TTimer;
    TrackBar1: TTrackBar;
    Label1: TLabel;
    Edit1: TEdit;
    Label2: TLabel;
    CheckBox1: TCheckBox;
    Bevel1: TBevel;
    Label3: TLabel;
    Bevel2: TBevel;
    procedure FormCreate(Sender: TObject);

    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure Timer1Timer(Sender: TObject);
    procedure TrackBar1Change(Sender: TObject);
  private
  public
  end;

//Struktur in der die Filetimes eines Prozesses
//gespeichert werden.
TCPULOAD = Record
  PID:                    Cardinal;
  Exename:                String;
  dwOldTime,dwNewTime:    Cardinal;
  lOldUser,lNewUser:      Cardinal;
  lOldKernel, lNewKernel: Cardinal;
  Show:                   Integer;
  end;

//Array in dem die Filetimes der einzelnen Prozesse
//gespeichert werden.
TCPULOADS = Array of TCPULOAD;

var
  Form1: TForm1;

implementation

var
  Progs: TCPULOADS;
  ftCreate, ftExit, ftUser, ftKernel: FileTime;
  TIME: CARDINAL;

{$R *.dfm}


function GetTime(ftTime:FileTime): Cardinal;
//Diese Funktion gibt mir gibt den Sekunden- und Millisekundenteil
//der Filetimes in MILLISEKUNDEN wieder...
//wird für die Berechnung neuezeit-altezeit gebraucht.
var
  stTime: SystemTime;
  iTime: cardinal;
begin
  FileTimeToSystemTime(ftTime,stTime);
  iTime := (stTime.wSecond*1000)+stTime.wMilliseconds;
  result := iTime;
end;

Function GetCpuProcUsage(lnewkernel,loldkernel,lnewuser,lolduser,dwNewTime,dwOldTime:cardinal): Cardinal;
//Diese Funktion berechnet aufgrund der diversen neu und altwerte die Prozessorauslastung eines
//Prozesses
var
  lUser, lKernel: Cardinal;
  dwTime: DWORD;
begin
  //hier wird die Differenz zwischen alter und neuer Kernelzeit ermittelt
  lKernel := lNewKernel - lOldKernel;
  //hier wird die Differenz zwischen alter und neuer Userzeit ermittelt
  lUser := lNewUser - lOldUser;
  //hier wird die Differenz zwischen dem alte und dem neuen Tickcount ermittelt
  //Erklärung siehe Hilfe zu GetTickCount(); [1 Tick ==> 1 Millisekunde]
  dwTime := dwNewTime - dwOldTime;
  //Gebe der Anwendung Zeit sich neu aufzubauen, hilfreich, wenn diese Funktion oft
  //hintereinander aufgerufen wird.
  Application.ProcessMessages;
  //hier wird die Tatsächliche Prozessorauslastung gemessen, indem
  //die Differenzen von Kernel und Userzeit addiert werden diese Addition wird
  //multipliziert mit 100 und dann durch die Tickcount-Differenz geteilt.
  //Rückgabe des ergebnisses
  if(dwTime>0) then Result := ((lKernel+lUser)*100) div (dwTime)
  else Result:=0;
end;

Function CheckID(PID: Integer): Boolean;
var i: integer;
begin
Result:=false;
for i:=0 to length(progs)-1 do
  if(progs[i].PID=PID) then begin Result:=true; break; end;
end;



procedure TForm1.Button1Click(Sender: TObject);
//Diese Funktion ermittelt alle momentan laufenden Prozesse
//und speichert Werte von diesen in dem eindimensionalen
//Array "progs"
var
  hSnap : THandle;
  pe32  : TProcessEntry32;
  i,e: integer;
  temp: TCPULOADS;
begin
  Timer1.Enabled:=false;
  //initiallisieren von Variablen
  i:=-1;
  ZeroMemory(@pe32, sizeof(pe32));
  pe32.dwSize := sizeof(TProcessEntry32);
  //Erstellt eine Momentaufnahme der Prozessumgebung (heap, threads, processes and so on)
  hSnap := CreateToolHelp32SnapShot(TH32CS_SNAPPROCESS, 0);
  //wenn erster Durchlauf erfolgreich, dann...
  if Process32First(hSnap, pe32) = TRUE then begin
    //solange ein Prozess gefunden wird
    while Process32Next(hSnap, pe32) = TRUE do begin
    //schreibe die Prozess-ID und den Anwendungsnamen in das eindimensionale Array "PROGS"
      inc(i);
      SetLength(temp,i+1);
      temp[i].PID:=pe32.th32ProcessID;
      temp[i].Exename:=pe32.szExeFile;
    end;
  end;
setlength(progs,i+1);
//übertrage altdaten von progs-array auf das temp-array
for i:=0 to length(temp)-1 do
  if(temp[i].PID=progs[i].PID) then temp[i]:=progs[i];
//überschreibe progs mit dem temp-array, notwendig damit neue
//Prozesse überwacht werden und geschlossene rausgeschmiessen werden.
progs:=temp;
TIME:=GetTickCount;
//Starte Timer
Timer1.Enabled:=true;
end;


procedure TForm1.Timer1Timer(Sender: TObject);
//Bei jedem Interval des Timers werden die Werte neu ermittelt
var
  i       : Integer;
  HLE     : THandle;
begin
If((Gettickcount-Time)>1000) then button1click(self);
    //durchlaufe alle datensaetze des eindimensionalen arrays "Progs"
    for i:=0 to length(progs)-1 do begin
      Zeromemory(@ftuser,sizeof(ftuser));
      Zeromemory(@ftuser,sizeof(ftkernel));
      //vertausche alte mit neuen Werten
      progs[i].dwOldTime  :=progs[i].dwnewTime;
      progs[i].lOldUser   :=progs[i].lNewUser;
      progs[i].lOldKernel :=progs[i].lNewKernel;
      //Ermittele neuen Tickcount
      progs[i].dwNewTime  := GetTickCount;
      //Process zum Informationen lesen öffnen
      HLE:=OpenProcess(PROCESS_QUERY_INFORMATION, false, progs[i].PID);
      //Wenn das Fenster der Unit bewegt wird, funktioniert die Openprocess-
      //Funktion nicht mehr richtig und gibt ein Handle=0 zurück.
      //Also Nur Neue Werte zuweisen, wenn HLE <> 0
      if(HLE<>0) then begin
        //Ermittele Erstellungszeit, ..., Kernelzeit und Userzeit des Prozesses
        GetProcessTimes(HLE, ftCreate, ftExit, ftKernel, ftUser);
        //Setze die neue User- und Kerneltime ins array
        progs[i].lNewUser   := GetTime( ftUser );
        progs[i].lNewKernel := GetTime( ftKernel );
      end;
      //Schliesse Prozesshandle
      CloseHandle(HLE);
    end;
//refreshe die Listbox
button2Click(self);
end;

procedure TForm1.Button2Click(Sender: TObject);
//Diese Funktion füllt die Listbox mit den Prozessen
//die eine CPUTime von über 0 haben oder eine
//hatten vor unter 10 Refreshzyklen
var i,e: integer;
    CPULAST: Integer;
begin
//Einträge aus der Listbox löschen
listbox1.Clear;
//initialisieren von e
e:=0;
//Schleife über jeden Prozess der in der Schleife gespeichert ist...
for i:=1 to length(progs)-1 do
  begin
  CPUlast:=GetCpuProcUsage(progs[i].lnewkernel,progs[i].loldkernel,progs[i].lnewuser,progs[i].lolduser,progs[i].dwNewTime,progs[i].dwOldTime);
  //zähle die CPUUsage der einzelnen Prozesse zusammen...
  inc(e,CPULAST);
  //Wenn ein Prozess mehr als 0% CPUTime benutzt, füge ihn in die Listbox ein
  //und falls der Filter gesetzt ist, der Filter mit dem Eintrag übereinstimmt
  if((CPULast>0)) then
    begin
    //Zeige den Prozess auch noch 10mal an, wenn die CPUTime wieder auf 0 sinkt
    //verbessert die Lesbarkeit!!
    progs[i].Show:=10;
    Listbox1.Items.Add(progs[i].Exename+^I+inttostr(CPULAST)+'%');
    end;
  //wenn die Showvariable über 0 ist und die CPUTime auf 0 oder unter null dann füge den Prozess ein.
  if((progs[i].Show>0) and (CPULAST<=0) ) then
    begin
    Listbox1.Items.Add(progs[i].Exename+^I+inttostr(CPULAST)+'%');
    //dezimiere die Showvariable
    dec(progs[i].Show);
    end;
  end;
//ziehe von hundert die ermittelte summe der prozesscputimes ab und es ergibt die
//CPUTime des Lehrlaufprozesses
ListBox1.Items.Add('Leerlaufprozess '+^I+IntToStr(100-e)+'%');
end;

procedure TForm1.TrackBar1Change(Sender: TObject);
begin
//wenn die Trackbar bewegt wird, schreibe den neuen wert in das interval-
//property des timers
Timer1.Interval:=trackbar1.Position;
//gebe das neue Timer-Interval an das Label1 aus.
Label1.Caption:='Refresh-Interval: '+IntTostr(trackbar1.Position)+'ms';
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
//einmal das Trackbar1Change-Ereigniss aufrufen...
trackbar1change(self);
setlength(progs,0);
end;

end.