Tips (1541)

Tip Rating (17):

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 NextObject(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 NextInstance(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 NextCounter(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 := NextCounter(CurCntr);
            end;
            {Get the next instance.}
            PerfInst := NextInstance(PerfInst);
          end;
        end;
      end;
      {Get the next object type}
      PerfObj := NextObject(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.