unit PerfInfo;
interface
uses
 Windows, SysUtils, Classes;
type
 TPerfCounter = record
  Counter: Integer;
  Value: TLargeInteger;
 end;
 TPerfCounters = Array of TPerfCounter;
 TPerfInstance = class
 private
  FName: string;
  FCounters: TPerfCounters;
 public
  property Name: string read FName;
  property Counters: TPerfCounters read FCounters;
 end;
 TPerfObject = class
 private
  FList: TList;
  FObjectID: DWORD;
  FMachine: string;
  function GetCount: Integer;
  function GetInstance(Index: Integer): TPerfInstance;
  procedure ReadInstances;
 public
  property ObjectID: DWORD read FObjectID;
  property Item[Index: Integer]: TPerfInstance
  read GetInstance; default;
  property Count: Integer read GetCount;
  constructor Create(const AMachine: string; AObjectID: DWORD);
  destructor Destroy; override;
 end;
procedure GetProcesses(const Machine: string; List: TStrings);
implementation
type
 PPerfDataBlock = ^TPerfDataBlock;
 TPerfDataBlock = record
  Signature: array[0..3] of WCHAR;
  LittleEndian: DWORD;
  Version: DWORD;
  Revision: DWORD;
  TotalByteLength: DWORD;
  HeaderLength: DWORD;
  NumObjectTypes: DWORD;
  DefaultObject: Longint;
  SystemTime: TSystemTime;
  PerfTime: TLargeInteger;
  PerfFreq: TLargeInteger;
  PerfTime100nSec: TLargeInteger;
  SystemNameLength: DWORD;
  SystemNameOffset: DWORD;
 end;
 PPerfObjectType = ^TPerfObjectType;
 TPerfObjectType = record
  TotalByteLength: DWORD;
  DefinitionLength: DWORD;
  HeaderLength: DWORD;
  ObjectNameTitleIndex: DWORD;
  ObjectNameTitle: LPWSTR;
  ObjectHelpTitleIndex: DWORD;
  ObjectHelpTitle: LPWSTR;
  DetailLevel: DWORD;
  NumCounters: DWORD;
  DefaultCounter: Longint;
  NumInstances: Longint;
  CodePage: DWORD;
  PerfTime: TLargeInteger;
  PerfFreq: TLargeInteger;
 end;
 PPerfCounterDefinition = ^TPerfCounterDefinition;
 TPerfCounterDefinition = record
  ByteLength: DWORD;
  CounterNameTitleIndex: DWORD;
  CounterNameTitle: LPWSTR;
  CounterHelpTitleIndex: DWORD;
  CounterHelpTitle: LPWSTR;
  DefaultScale: Longint;
  DetailLevel: DWORD;
  CounterType: DWORD;
  CounterSize: DWORD;
  CounterOffset: DWORD;
 end;
 PPerfInstanceDefinition = ^TPerfInstanceDefinition;
 TPerfInstanceDefinition = record
  ByteLength: DWORD;
  ParentObjectTitleIndex: DWORD;
  ParentObjectInstance: DWORD;
  UniqueID: Longint;
  NameOffset: DWORD;
  NameLength: DWORD;
 end;
 PPerfCounterBlock = ^TPerfCounterBlock;
 TPerfCounterBlock = record
  ByteLength: DWORD;
 end;

{Navigation helpers}
function FirstObject(PerfData: PPerfDataBlock): PPerfObjectType;
begin
 Result := PPerfObjectType(DWORD(PerfData) + PerfData.HeaderLength);
end;

function Object(PerfObj: PPerfObjectType): PPerfObjectType;
begin
 Result := PPerfObjectType(DWORD(PerfObj) + PerfObj.TotalByteLength);
end;

function FirstInstance(PerfObj: PPerfObjectType): PPerfInstanceDefinition;
begin
 Result := PPerfInstanceDefinition(DWORD(PerfObj) + PerfObj.DefinitionLength);
end;

function Instance(PerfInst: PPerfInstanceDefinition): PPerfInstanceDefinition;
var
 PerfCntrBlk: PPerfCounterBlock;
begin
 PerfCntrBlk := PPerfCounterBlock(DWORD(PerfInst) + PerfInst.ByteLength);
 Result := PPerfInstanceDefinition(DWORD(PerfCntrBlk) + PerfCntrBlk.ByteLength);
end;

function FirstCounter(PerfObj: PPerfObjectType): PPerfCounterDefinition;
begin
 Result := PPerfCounterDefinition(DWORD(PerfObj) + PerfObj.HeaderLength);
end;

function Counter(PerfCntr: PPerfCounterDefinition): PPerfCounterDefinition;
begin
 Result := PPerfCounterDefinition(DWORD(PerfCntr) + PerfCntr.ByteLength);
end;

{Registry helpers}
function GetPerformanceKey(const Machine: string): HKey;
var
 s: string;
begin
 Result := 0;
 if Length(Machine) = 0 then
  Result := HKEY_PERFORMANCE_DATA
 else
 begin
  s := Machine;
  if Pos('\\', s) <> 1 then
  s := '\\' + s;
  if RegConnectRegistry(PChar(s), HKEY_PERFORMANCE_DATA, Result) <> ERROR_SUCCESS then
  Result := 0;
 end;
end;

{TPerfObject}
constructor TPerfObject.Create(const AMachine: string; AObjectID: DWORD);
begin
 inherited Create;
 FList := TList.Create;
 FMachine := AMachine;
 FObjectID := AObjectID;
 ReadInstances;
end;

destructor TPerfObject.Destroy;
var
 i: Integer;
begin
 for i := 0 to FList.Count - 1 do
  TPerfInstance(FList[i]).Free;
 FList.Free;
 inherited Destroy;
end;

function TPerfObject.GetCount: Integer;
begin
 Result := FList.Count;
end;

function TPerfObject.GetInstance(Index: Integer): TPerfInstance;
begin
 Result := FList[Index];
end;

procedure TPerfObject.ReadInstances;
var
 PerfData: PPerfDataBlock;
 PerfObj: PPerfObjectType;
 PerfInst: PPerfInstanceDefinition;
 PerfCntr, CurCntr: PPerfCounterDefinition;
 PtrToCntr: PPerfCounterBlock;
 BufferSize: Integer;
 i, j, k: Integer;
 pData: PLargeInteger;
 Key: HKey;
 CurInstance: TPerfInstance;
begin
 for i := 0 to FList.Count - 1 do
  TPerfInstance(FList[i]).Free;
 FList.Clear;
 Key := GetPerformanceKey(FMachine);
 if Key = 0 then Exit;
 PerfData := nil;
 try
  {Allocate initial buffer for object information}
  BufferSize := 65536;
  GetMem(PerfData, BufferSize);
  {retrieve data}
  while RegQueryValueEx(Key,
  PChar(IntToStr(FObjectID)), {Object name}
  nil, nil, Pointer(PerfData), @BufferSize) = ERROR_MORE_DATA do
  begin
  {buffer is too small}
  Inc(BufferSize, 1024);
  ReallocMem(PerfData, BufferSize);
  end;
  RegCloseKey(HKEY_PERFORMANCE_DATA);
  {Get the first object type}
  PerfObj := FirstObject(PerfData);
  {Process all objects}
  for i := 0 to PerfData.NumObjectTypes - 1 do
  begin
  {Check for requested object}
  if PerfObj.ObjectNameTitleIndex = FObjectID then
  begin
  {Get the first counter}
  PerfCntr := FirstCounter(PerfObj);
  if PerfObj.NumInstances > 0 then
  begin
  {Get the first instance}
  PerfInst := FirstInstance(PerfObj);
  {Retrieve all instances}
  for k := 0 to PerfObj.NumInstances - 1 do
  begin
  {Create entry for instance}
  CurInstance := TPerfInstance.Create;
  CurInstance.FName := WideCharToString(PWideChar(DWORD(PerfInst) +
  PerfInst.NameOffset));
  FList.Add(CurInstance);
  CurCntr := PerfCntr;
  {Retrieve all counters}
  SetLength(CurInstance.FCounters, PerfObj.NumCounters);
  for j := 0 to PerfObj.NumCounters - 1 do
  begin
  PtrToCntr := PPerfCounterBlock(DWORD(PerfInst) + PerfInst.ByteLength);
  pData := Pointer(DWORD(PtrToCntr) + CurCntr.CounterOffset);
  {Add counter to array}
  CurInstance.FCounters[j].Counter := CurCntr.CounterNameTitleIndex;
  CurInstance.FCounters[j].Value := pData^;
  {Get the next counter}
  CurCntr := Counter(CurCntr);
  end;
  {Get the next instance.}
  PerfInst := Instance(PerfInst);
  end;
  end;
  end;
  {Get the next object type}
  PerfObj := Object(PerfObj);
  end;
 finally
  {Release buffer}
  FreeMem(PerfData);
  {Close remote registry handle}
  if Key <> HKEY_PERFORMANCE_DATA then
  RegCloseKey(Key);
 end;
end;

procedure GetProcesses(const Machine: string; List: TStrings);
var
 Processes: TPerfObject;
 i, j: Integer;
 ProcessID: DWORD;
begin
 Processes := nil;
 List.Clear;
 try
  Processes := TPerfObject.Create(Machine, 230); {230 = Process}
  for i := 0 to Processes.Count - 1 do
  {Find process ID}
  for j := 0 to Length(Processes[i].Counters) - 1 do
  if (Processes[i].Counters[j].Counter = 784) then
  begin
  ProcessID := Processes[i].Counters[j].Value;
  if ProcessID <> 0 then
  List.AddObject(Processes[i].Name, Pointer(ProcessID));
  Break;
  end;
 finally
  Processes.Free;
 end;
end;
end.