2009-11-10 25 views

Respuesta

12

This article parece proporcionar el código que necesita para controlar el uso de la CPU para un proceso utilizando Delphi nativo. Lo que sigue es una cita directa del artículo anterior.

Uso de la unidad

Al comenzar a controlar un proceso, llame cnt: = wsCreateUsageCounter (ID_proceso) para inicializar un contador de uso. Cuando necesite obtener el uso actual de la CPU de ese proceso, use use: = wsGetCpuUsage (cnt). Cuando haya terminado de supervisar el proceso , llame a wsDestroyUsageCounter (cnt) para liberar la memoria utilizada por el contador de uso y cierre los identificadores abiertos.

La unidad uCpuUsage

unit uCpuUsage; 

interface 
const 
    wsMinMeasurementInterval=250; {minimum amount of time that must have elapsed to calculate CPU usage, miliseconds. If time elapsed is less than this, previous result is returned, or zero, if there is no previous result.} 
type 
    TCPUUsageData=record 
     PID,Handle:cardinal; 
     oldUser,oldKernel:Int64; 
     LastUpdateTime:cardinal; 
     LastUsage:single; 
     //Last result of wsGetCpuUsage is saved here 
     Tag:cardinal; 
     //Use it for anythin you like, not modified by this unit 
    end; 
    PCPUUsageData=^TCPUUsageData; 

function wsCreateUsageCounter(PID:cardinal):PCPUUsageData; 
function wsGetCpuUsage(aCounter:PCPUUsageData):single; 
procedure wsDestroyUsageCounter(aCounter:PCPUUsageData); 

implementation 

uses Windows; 

function wsCreateUsageCounter(PID:cardinal):PCPUUsageData; 
var 
    p:PCPUUsageData; 
    mCreationTime,mExitTime,mKernelTime, mUserTime:_FILETIME; 
    h:cardinal; 
begin 
    result:=nil; 
    //We need a handle with PROCESS_QUERY_INFORMATION privileges 
    h:=OpenProcess(PROCESS_QUERY_INFORMATION,false,PID); 
    if h=0 then exit; 
    new(p); 
    p.PID:=PID; 
    p.Handle:=h; 
    p.LastUpdateTime:=GetTickCount; 
    p.LastUsage:=0; 
    if GetProcessTimes(p.Handle, mCreationTime, mExitTime, mKernelTime, mUserTime) then begin 
     //convert _FILETIME to Int64 
     p.oldKernel:=int64(mKernelTime.dwLowDateTime or (mKernelTime.dwHighDateTime shr 32)); 
     p.oldUser:=int64(mUserTime.dwLowDateTime or (mUserTime.dwHighDateTime shr 32)); 
     Result:=p; 
    end else begin 
     dispose(p); 
    end; 
end; 

procedure wsDestroyUsageCounter(aCounter:PCPUUsageData); 
begin 
    CloseHandle(aCounter.Handle); 
    dispose(aCounter); 
end; 

function wsGetCpuUsage(aCounter:PCPUUsageData):single; 
var 
    mCreationTime,mExitTime,mKernelTime, mUserTime:_FILETIME; 
    DeltaMs,ThisTime:cardinal; 
    mKernel,mUser,mDelta:int64; 
begin 
    result:=aCounter.LastUsage; 
    ThisTime:=GetTickCount; //Get the time elapsed since last query 

    DeltaMs:=ThisTime-aCounter.LastUpdateTime; 
    if DeltaMs < wsMinMeasurementInterval then exit; 
aCounter.LastUpdateTime:=ThisTime; 

    GetProcessTimes(aCounter.Handle,mCreationTime, mExitTime, mKernelTime, mUserTime); 
    //convert _FILETIME to Int64. 
    mKernel:=int64(mKernelTime.dwLowDateTime or (mKernelTime.dwHighDateTime shr 32)); 
    mUser:=int64(mUserTime.dwLowDateTime or (mUserTime.dwHighDateTime shr 32)); 
    //get the delta 
    mDelta:=mUser+mKernel-aCounter.oldUser-aCounter.oldKernel; 

    aCounter.oldUser:=mUser; 
    aCounter.oldKernel:=mKernel; 

    Result:=(mDelta/DeltaMs)/100; 
    //mDelta is in units of 100 nanoseconds, so… 

    aCounter.LastUsage:=Result; 
    //just in case you want to use it later, too 
end; 

end. 
+10

Sí, solo asegúrese de contar el número de CPU y dividir el resultado por eso, de lo contrario obtendrá un porcentaje incorrecto en sistemas multi-core: usa Windows; función GetCpuCount: Word; var SysInfo: _SYSTEM_INFO; begin GetSystemInfo (SysInfo); Resultado: = SysInfo.dwNumberOfProcessors; final; – vcldeveloper

+0

bueno saber.un buen truco ;-) – stanleyxu2005

-3

acaba de obtener una lista de procesos en ejecución:

procedure TForm1.Button1Click(Sender: TObject); 
var 
    handler: THandle; 
    data: TProcessEntry32; 

    function GetName: string; 
    var i:byte; 
    begin 
    Result := ''; 
    i := 0; 
    while data.szExeFile[i] <> '' do 
    begin 
     Result := Result + data.szExeFile[i]; 
     Inc(i); 
    end; 
    end; 

begin 
    handler := CreateToolhelp32Snapshot(TH32CS_SNAPALL, 0); 
    if Process32First(handler, data) then 
    begin 
    listbox1.Items.Add(GetName()); 

    while Process32Next(handler, data) do 
     listbox1.Items.Add(GetName()); 
    end 
    else 
    ShowMessage('Error'); 
end; 

A continuación, sólo comprobar el uso de todos los procesos. No tengo conocimiento de ninguna otra opción admitida directamente por el SO o Delphi para ese asunto.

+0

no es útil, no pertinentes – CyprUS

3

¿No puedes usar wmi api?

+0

Gracias por la pista. Encontré una solución en http://www.experts-exchange.com/Programming/Languages/Pascal/Delphi/Q_21110830.html Antes de usar este código, primero se debe generar una unidad WbemScripting_TLB. – stanleyxu2005

4

Ver a mi unidad de PerfUtils. Necesitará una traducción de Delphi de Winperf.h, puede usar WinPerf.pas de Marcel van Brakel o JwaWinPerf.pas del JEDI API Library. Eche un vistazo a la función GetProcessPercentProcessorTime.

Ejemplo de uso:

var 
    Data1, Data2: PPerfDataBlock; 
    ProcessorCount: Integer; 
    PercentProcessorTime: Double; 
begin 
    ProcessorCount := GetProcessorCount; 
    Data1 := GetPerformanceData(IntToStr(ObjProcess)); 
    Sleep(1000); 
    Data2 := GetPerformanceData(IntToStr(ObjProcess)); 

    PercentProcessorTime := GetProcessPercentProcessorTime(ProcessID, Data1, Data2, ProcessorCount); 
    // ... 
end; 

PerfUtils.pas:

unit PerfUtils; 

interface 

uses 
    Windows, SysUtils, 
    WinPerf; 

type 
    PPerfLibHeader = ^TPerfLibHeader; 
    TPerfLibHeader = packed record 
    Signature: array[0..7] of Char; 
    DataSize: Cardinal; 
    ObjectCount: Cardinal; 
    end; 

function GetCounterBlock(Obj: PPerfObjectType): PPerfCounterBlock; overload; 
function GetCounterBlock(Instance: PPerfInstanceDefinition): PPerfCounterBlock; overload; 
function GetCounterDataAddress(Obj: PPerfObjectType; Counter: PPerfCounterDefinition; 
    Instance: PPerfInstanceDefinition = nil): Pointer; overload; 
function GetCounterDataAddress(Obj: PPerfObjectType; Counter, Instance: Integer): Pointer; overload; 
function GetCounter(Obj: PPerfObjectType; Index: Integer): PPerfCounterDefinition; 
function GetCounterByNameIndex(Obj: PPerfObjectType; NameIndex: Cardinal): PPerfCounterDefinition; 
function GetCounterValue32(Obj: PPerfObjectType; Counter: PPerfCounterDefinition; 
    Instance: PPerfInstanceDefinition = nil): Cardinal; 
function GetCounterValue64(Obj: PPerfObjectType; Counter: PPerfCounterDefinition; 
    Instance: PPerfInstanceDefinition = nil): UInt64; 
function GetCounterValueText(Obj: PPerfObjectType; Counter: PPerfCounterDefinition; 
    Instance: PPerfInstanceDefinition = nil): PChar; 
function GetCounterValueWideText(Obj: PPerfObjectType; Counter: PPerfCounterDefinition; 
    Instance: PPerfInstanceDefinition = nil): PWideChar; 
function GetFirstCounter(Obj: PPerfObjectType): PPerfCounterDefinition; 
function GetFirstInstance(Obj: PPerfObjectType): PPerfInstanceDefinition; 
function GetFirstObject(Data: PPerfDataBlock): PPerfObjectType; overload; 
function GetFirstObject(Header: PPerfLibHeader): PPerfObjectType; overload; 
function GetInstance(Obj: PPerfObjectType; Index: Integer): PPerfInstanceDefinition; 
function GetInstanceName(Instance: PPerfInstanceDefinition): PWideChar; 
function GetNextCounter(Counter: PPerfCounterDefinition): PPerfCounterDefinition; 
function GetNextInstance(Instance: PPerfInstanceDefinition): PPerfInstanceDefinition; 
function GetNextObject(Obj: PPerfObjectType): PPerfObjectType; 
function GetObjectSize(Obj: PPerfObjectType): Cardinal; 
function GetObject(Data: PPerfDataBlock; Index: Integer): PPerfObjectType; overload; 
function GetObject(Header: PPerfLibHeader; Index: Integer): PPerfObjectType; overload; 
function GetObjectByNameIndex(Data: PPerfDataBlock; NameIndex: Cardinal): PPerfObjectType; overload; 
function GetObjectByNameIndex(Header: PPerfLibHeader; NameIndex: Cardinal): PPerfObjectType; overload; 
function GetPerformanceData(const RegValue: string): PPerfDataBlock; 
function GetProcessInstance(Obj: PPerfObjectType; ProcessID: Cardinal): PPerfInstanceDefinition; 
function GetSimpleCounterValue32(ObjIndex, CtrIndex: Integer): Cardinal; 
function GetSimpleCounterValue64(ObjIndex, CtrIndex: Integer): UInt64; 

function GetProcessName(ProcessID: Cardinal): WideString; 
function GetProcessPercentProcessorTime(ProcessID: Cardinal; Data1, Data2: PPerfDataBlock; 
    ProcessorCount: Integer = -1): Double; 
function GetProcessPrivateBytes(ProcessID: Cardinal): UInt64; 
function GetProcessThreadCount(ProcessID: Cardinal): Cardinal; 
function GetProcessVirtualBytes(ProcessID: Cardinal): UInt64; 
function GetProcessorCount: Integer; 
function GetSystemProcessCount: Cardinal; 
function GetSystemUpTime: TDateTime; 

var 
    PerfFrequency: Int64 = 0; 

const 
    // perfdisk.dll 
    ObjPhysicalDisk = 234; 
    ObjLogicalDisk = 236; 
    // perfnet.dll 
    ObjBrowser = 52; 
    ObjRedirector = 262; 
    ObjServer = 330; 
    ObjServerWorkQueues = 1300; 
    // perfos.dll 
    ObjSystem = 2; 
    CtrProcesses = 248; 
    CtrSystemUpTime = 674; 
    ObjMemory = 4; 
    ObjCache = 86; 
    ObjProcessor = 238; 
    ObjObjects = 260; 
    ObjPagingFile = 700; 
    // perfproc.dll 
    ObjProcess = 230; 
    CtrPercentProcessorTime = 6; 
    CtrVirtualBytes = 174; 
    CtrPrivateBytes = 186; 
    CtrThreadCount = 680; 
    CtrIDProcess = 784; 
    ObjThread = 232; 
    ObjProcessAddressSpace = 786; 
    ObjImage = 740; 
    ObjThreadDetails = 816; 
    ObjFullImage = 1408; 
    ObjJobObject = 1500; 
    ObjJobObjectDetails = 1548; 
    ObjHeap = 1760; 
    // winspool.drv 
    ObjPrintQueue = 1450; 
    // tapiperf.dll 
    ObjTelephony = 1150; 
    // perfctrs.dll 
    ObjNBTConnection = 502; 
    ObjNetworkInterface = 510; 
    ObjIP = 546; 
    ObjICMP = 582; 
    ObjTCP = 638; 
    ObjUDP = 658; 

implementation 

function GetCounterBlock(Obj: PPerfObjectType): PPerfCounterBlock; 
begin 
    if Assigned(Obj) and (Obj^.NumInstances = PERF_NO_INSTANCES) then 
    Cardinal(Result) := Cardinal(Obj) + SizeOf(TPerfObjectType) + (Obj^.NumCounters * SizeOf(TPerfCounterDefinition)) 
    else 
    Result := nil; 
end; 

function GetCounterBlock(Instance: PPerfInstanceDefinition): PPerfCounterBlock; 
begin 
    if Assigned(Instance) then 
    Cardinal(Result) := Cardinal(Instance) + Instance^.ByteLength 
    else 
    Result := nil; 
end; 

function GetCounterDataAddress(Obj: PPerfObjectType; Counter: PPerfCounterDefinition; 
    Instance: PPerfInstanceDefinition = nil): Pointer; 
var 
    Block: PPerfCounterBlock; 
begin 
    Result := nil; 
    if not Assigned(Obj) or not Assigned(Counter) then 
    Exit; 

    if Obj^.NumInstances = PERF_NO_INSTANCES then 
    Block := GetCounterBlock(Obj) 
    else 
    begin 
    if not Assigned(Instance) then 
     Exit; 

    Block := GetCounterBlock(Instance); 
    end; 

    if not Assigned(Block) then 
    Exit; 

    Cardinal(Result) := Cardinal(Block) + Counter^.CounterOffset; 
end; 

function GetCounterDataAddress(Obj: PPerfObjectType; Counter, Instance: Integer): Pointer; 
begin 
    Result := nil; 
    if not Assigned(Obj) or (Counter < 0) or (Cardinal(Counter) > Obj^.NumCounters - 1) then 
    Exit; 

    if Obj^.NumInstances = PERF_NO_INSTANCES then 
    begin 
    if Instance <> -1 then 
     Exit; 
    end 
    else 
    begin 
    if (Instance < 0) or (Instance > Obj^.NumInstances - 1) then 
     Exit; 
    end; 

    Result := GetCounterDataAddress(Obj, GetCounter(Obj, Counter), GetInstance(Obj, Instance)); 
end; 

function GetCounter(Obj: PPerfObjectType; Index: Integer): PPerfCounterDefinition; 
var 
    I: Integer; 
begin 
    if Assigned(Obj) and (Index >= 0) and (Cardinal(Index) <= Obj^.NumCounters - 1) then 
    begin 
    Result := GetFirstCounter(Obj); 
    if not Assigned(Result) then 
     Exit; 

    for I := 0 to Index - 1 do 
    begin 
     Result := GetNextCounter(Result); 
     if not Assigned(Result) then 
     Exit; 
    end; 
    end 
    else 
    Result := nil; 
end; 

function GetCounterByNameIndex(Obj: PPerfObjectType; NameIndex: Cardinal): PPerfCounterDefinition; 
var 
    Counter: PPerfCounterDefinition; 
    I: Integer; 
begin 
    Result := nil; 

    Counter := GetFirstCounter(Obj); 
    for I := 0 to Obj^.NumCounters - 1 do 
    begin 
    if not Assigned(Counter) then 
     Exit; 

    if Counter^.CounterNameTitleIndex = NameIndex then 
    begin 
     Result := Counter; 
     Break; 
    end; 

    Counter := GetNextCounter(Counter); 
    end; 
end; 

function GetCounterValue32(Obj: PPerfObjectType; Counter: PPerfCounterDefinition; 
    Instance: PPerfInstanceDefinition = nil): Cardinal; 
var 
    DataAddr: Pointer; 
begin 
    Result := 0; 

    DataAddr := GetCounterDataAddress(Obj, Counter, Instance); 
    if not Assigned(DataAddr) then 
    Exit; 

    if Counter^.CounterType and $00000300 = PERF_SIZE_DWORD then // 32-bit value 
    case Counter^.CounterType and $00000C00 of // counter type 
     PERF_TYPE_NUMBER, PERF_TYPE_COUNTER: 
     Result := PCardinal(DataAddr)^; 
    end; 
end; 

function GetCounterValue64(Obj: PPerfObjectType; Counter: PPerfCounterDefinition; 
    Instance: PPerfInstanceDefinition = nil): UInt64; 
var 
    DataAddr: Pointer; 
begin 
    Result := 0; 

    DataAddr := GetCounterDataAddress(Obj, Counter, Instance); 
    if not Assigned(DataAddr) then 
    Exit; 

    if Counter^.CounterType and $00000300 = PERF_SIZE_LARGE then // 64-bit value 
    case Counter^.CounterType and $00000C00 of // counter type 
     PERF_TYPE_NUMBER, PERF_TYPE_COUNTER: 
     Result := Uint64(PInt64(DataAddr)^); 
    end; 
end; 

function GetCounterValueText(Obj: PPerfObjectType; Counter: PPerfCounterDefinition; 
    Instance: PPerfInstanceDefinition = nil): PChar; 
var 
    DataAddr: Pointer; 
begin 
    Result := nil; 

    DataAddr := GetCounterDataAddress(Obj, Counter, Instance); 
    if not Assigned(DataAddr) then 
    Exit; 

    if Counter^.CounterType and $00000300 = PERF_SIZE_VARIABLE_LEN then // variable-length value 
    if (Counter^.CounterType and $00000C00 = PERF_TYPE_TEXT) and 
     (Counter^.CounterType and $00010000 = PERF_TEXT_ASCII) then 
     Result := PChar(DataAddr); 
end; 

function GetCounterValueWideText(Obj: PPerfObjectType; Counter: PPerfCounterDefinition; 
    Instance: PPerfInstanceDefinition = nil): PWideChar; 
var 
    DataAddr: Pointer; 
begin 
    Result := nil; 

    DataAddr := GetCounterDataAddress(Obj, Counter, Instance); 
    if not Assigned(DataAddr) then 
    Exit; 

    if Counter^.CounterType and $00000300 = PERF_SIZE_VARIABLE_LEN then // variable-length value 
    if (Counter^.CounterType and $00000C00 = PERF_TYPE_TEXT) and 
     (Counter^.CounterType and $00010000 = PERF_TEXT_UNICODE) then 
     Result := PWideChar(DataAddr); 
end; 

function GetFirstCounter(Obj: PPerfObjectType): PPerfCounterDefinition; 
begin 
    if Assigned(Obj) then 
    Cardinal(Result) := Cardinal(Obj) + Obj^.HeaderLength 
    else 
    Result := nil; 
end; 

function GetFirstInstance(Obj: PPerfObjectType): PPerfInstanceDefinition; 
begin 
    if not Assigned(Obj) or (Obj^.NumInstances = PERF_NO_INSTANCES) then 
    Result := nil 
    else 
    Cardinal(Result) := Cardinal(Obj) + SizeOf(TPerfObjectType) + (Obj^.NumCounters * SizeOf(TPerfCounterDefinition)); 
end; 

function GetFirstObject(Data: PPerfDataBlock): PPerfObjectType; overload; 
begin 
    if Assigned(Data) then 
    Cardinal(Result) := Cardinal(Data) + Data^.HeaderLength 
    else 
    Result := nil; 
end; 

function GetFirstObject(Header: PPerfLibHeader): PPerfObjectType; overload; 
begin 
    if Assigned(Header) then 
    Cardinal(Result) := Cardinal(Header) + SizeOf(TPerfLibHeader) 
    else 
    Result := nil; 
end; 

function GetInstance(Obj: PPerfObjectType; Index: Integer): PPerfInstanceDefinition; 
var 
    I: Integer; 
begin 
    if Assigned(Obj) and (Index >= 0) and (Index <= Obj^.NumInstances - 1) then 
    begin 
    Result := GetFirstInstance(Obj); 
    if not Assigned(Result) then 
     Exit; 

    for I := 0 to Index - 1 do 
    begin 
     Result := GetNextInstance(Result); 
     if not Assigned(Result) then 
     Exit; 
    end; 
    end 
    else 
    Result := nil; 
end; 

function GetInstanceName(Instance: PPerfInstanceDefinition): PWideChar; 
begin 
    if Assigned(Instance) then 
    Cardinal(Result) := Cardinal(Instance) + Instance^.NameOffset 
    else 
    Result := nil; 
end; 

function GetNextCounter(Counter: PPerfCounterDefinition): PPerfCounterDefinition; 
begin 
    if Assigned(Counter) then 
    Cardinal(Result) := Cardinal(Counter) + Counter^.ByteLength 
    else 
    Result := nil; 
end; 

function GetNextInstance(Instance: PPerfInstanceDefinition): PPerfInstanceDefinition; 
var 
    Block: PPerfCounterBlock; 
begin 
    Block := GetCounterBlock(Instance); 
    if Assigned(Block) then 
    Cardinal(Result) := Cardinal(Block) + Block^.ByteLength 
    else 
    Result := nil; 
end; 

function GetNextObject(Obj: PPerfObjectType): PPerfObjectType; 
begin 
    if Assigned(Obj) then 
    Cardinal(Result) := Cardinal(Obj) + Obj^.TotalByteLength 
    else 
    Result := nil; 
end; 

function GetObjectSize(Obj: PPerfObjectType): Cardinal; 
var 
    I: Integer; 
    Instance: PPerfInstanceDefinition; 
begin 
    Result := 0; 

    if Assigned(Obj) then 
    begin 
    if Obj^.NumInstances = PERF_NO_INSTANCES then 
     Result := Obj^.TotalByteLength 
    else 
    begin 
     Instance := GetFirstInstance(Obj); 
     if not Assigned(Instance) then 
     Exit; 

     for I := 0 to Obj^.NumInstances - 1 do 
     begin 
     Instance := GetNextInstance(Instance); 
     if not Assigned(Instance) then 
      Exit; 
     end; 

     Result := Cardinal(Instance) - Cardinal(Obj); 
    end; 
    end; 
end; 

function GetObject(Data: PPerfDataBlock; Index: Integer): PPerfObjectType; 
var 
    I: Integer; 
begin 
    if Assigned(Data) and (Index >= 0) and (Cardinal(Index) <= Data^.NumObjectTypes - 1) then 
    begin 
    Result := GetFirstObject(Data); 
    if not Assigned(Result) then 
     Exit; 

    for I := 0 to Index - 1 do 
    begin 
     Result := GetNextObject(Result); 
     if not Assigned(Result) then 
     Exit; 
    end; 
    end 
    else 
    Result := nil; 
end; 

function GetObject(Header: PPerfLibHeader; Index: Integer): PPerfObjectType; 
var 
    I: Integer; 
begin 
    if Assigned(Header) and (Index >= 0) then 
    begin 
    Result := GetFirstObject(Header); 
    if not Assigned(Result) then 
     Exit; 

    for I := 0 to Index - 1 do 
    begin 
     Result := GetNextObject(Result); 
     if not Assigned(Result) then 
     Exit; 
    end; 
    end 
    else 
    Result := nil; 
end; 

function GetObjectByNameIndex(Data: PPerfDataBlock; NameIndex: Cardinal): PPerfObjectType; 
var 
    Obj: PPerfObjectType; 
    I: Integer; 
begin 
    Result := nil; 

    Obj := GetFirstObject(Data); 
    for I := 0 to Data^.NumObjectTypes - 1 do 
    begin 
    if not Assigned(Obj) then 
     Exit; 

    if Obj^.ObjectNameTitleIndex = NameIndex then 
    begin 
     Result := Obj; 
     Break; 
    end; 

    Obj := GetNextObject(Obj); 
    end; 
end; 

function GetObjectByNameIndex(Header: PPerfLibHeader; NameIndex: Cardinal): PPerfObjectType; overload; 
var 
    Obj: PPerfObjectType; 
    I: Integer; 
begin 
    Result := nil; 

    Obj := GetFirstObject(Header); 
    for I := 0 to Header^.ObjectCount - 1 do 
    begin 
    if not Assigned(Obj) then 
     Exit; 

    if Obj^.ObjectNameTitleIndex = NameIndex then 
    begin 
     Result := Obj; 
     Break; 
    end; 

    Obj := GetNextObject(Obj); 
    end; 
end; 

function GetPerformanceData(const RegValue: string): PPerfDataBlock; 
const 
    BufSizeInc = 4096; 
var 
    BufSize, RetVal: Cardinal; 
begin 
    BufSize := BufSizeInc; 
    Result := AllocMem(BufSize); 
    try 
    RetVal := RegQueryValueEx(HKEY_PERFORMANCE_DATA, PChar(RegValue), nil, nil, PByte(Result), @BufSize); 
    try 
     repeat 
     case RetVal of 
      ERROR_SUCCESS: 
      Break; 
      ERROR_MORE_DATA: 
      begin 
       Inc(BufSize, BufSizeInc); 
       ReallocMem(Result, BufSize); 
       RetVal := RegQueryValueEx(HKEY_PERFORMANCE_DATA, PChar(RegValue), nil, nil, PByte(Result), @BufSize); 
      end; 
      else 
      RaiseLastOSError; 
     end; 
     until False; 
    finally 
     RegCloseKey(HKEY_PERFORMANCE_DATA); 
    end; 
    except 
    FreeMem(Result); 
    raise; 
    end; 
end; 

function GetProcessInstance(Obj: PPerfObjectType; ProcessID: Cardinal): PPerfInstanceDefinition; 
var 
    Counter: PPerfCounterDefinition; 
    Instance: PPerfInstanceDefinition; 
    Block: PPerfCounterBlock; 
    I: Integer; 
begin 
    Result := nil; 

    Counter := GetCounterByNameIndex(Obj, CtrIDProcess); 
    if not Assigned(Counter) then 
    Exit; 

    Instance := GetFirstInstance(Obj); 
    for I := 0 to Obj^.NumInstances - 1 do 
    begin 
    Block := GetCounterBlock(Instance); 
    if not Assigned(Block) then 
     Exit; 

    if PCardinal(Cardinal(Block) + Counter^.CounterOffset)^ = ProcessID then 
    begin 
     Result := Instance; 
     Break; 
    end; 

    Instance := GetNextInstance(Instance); 
    end; 
end; 

function GetSimpleCounterValue32(ObjIndex, CtrIndex: Integer): Cardinal; 
var 
    Data: PPerfDataBlock; 
    Obj: PPerfObjectType; 
    Counter: PPerfCounterDefinition; 
begin 
    Result := 0; 

    Data := GetPerformanceData(IntToStr(ObjIndex)); 
    try 
    Obj := GetObjectByNameIndex(Data, ObjIndex); 
    if not Assigned(Obj) then 
     Exit; 

    Counter := GetCounterByNameIndex(Obj, CtrIndex); 
    if not Assigned(Counter) then 
     Exit; 

    Result := GetCounterValue32(Obj, Counter); 
    finally 
    FreeMem(Data); 
    end; 
end; 

function GetSimpleCounterValue64(ObjIndex, CtrIndex: Integer): UInt64; 
var 
    Data: PPerfDataBlock; 
    Obj: PPerfObjectType; 
    Counter: PPerfCounterDefinition; 
begin 
    Result := 0; 

    Data := GetPerformanceData(IntToStr(ObjIndex)); 
    try 
    Obj := GetObjectByNameIndex(Data, ObjIndex); 
    if not Assigned(Obj) then 
     Exit; 

    Counter := GetCounterByNameIndex(Obj, CtrIndex); 
    if not Assigned(Counter) then 
     Exit; 

    Result := GetCounterValue64(Obj, Counter); 
    finally 
    FreeMem(Data); 
    end; 
end; 

function GetProcessName(ProcessID: Cardinal): WideString; 
var 
    Data: PPerfDataBlock; 
    Obj: PPerfObjectType; 
    Instance: PPerfInstanceDefinition; 
begin 
    Result := ''; 

    Data := GetPerformanceData(IntToStr(ObjProcess)); 
    try 
    Obj := GetObjectByNameIndex(Data, ObjProcess); 
    if not Assigned(Obj) then 
     Exit; 

    Instance := GetProcessInstance(Obj, ProcessID); 
    if not Assigned(Instance) then 
     Exit; 

    Result := GetInstanceName(Instance); 
    finally 
    FreeMem(Data); 
    end; 
end; 

function GetProcessPercentProcessorTime(ProcessID: Cardinal; Data1, Data2: PPerfDataBlock; 
    ProcessorCount: Integer): Double; 
var 
    Value1, Value2: UInt64; 

    function GetValue(Data: PPerfDataBlock): UInt64; 
    var 
    Obj: PPerfObjectType; 
    Instance: PPerfInstanceDefinition; 
    Counter: PPerfCounterDefinition; 
    begin 
    Result := 0; 

    Obj := GetObjectByNameIndex(Data, ObjProcess); 
    if not Assigned(Obj) then 
     Exit; 
    Counter := GetCounterByNameIndex(Obj, CtrPercentProcessorTime); 
    if not Assigned(Counter) then 
     Exit; 
    Instance := GetProcessInstance(Obj, ProcessID); 
    if not Assigned(Instance) then 
     Exit; 

    Result := GetCounterValue64(Obj, Counter, Instance); 
    end; 
begin 
    if ProcessorCount = -1 then 
    ProcessorCount := GetProcessorCount; 

    Value1 := GetValue(Data1); 
    Value2 := GetValue(Data2); 

    Result := 100 * (Value2 - Value1)/(Data2^.PerfTime100nSec.QuadPart - Data1^.PerfTime100nSec.QuadPart) 
    /ProcessorCount; 
end; 

function GetProcessPrivateBytes(ProcessID: Cardinal): UInt64; 
var 
    Data: PPerfDataBlock; 
    Obj: PPerfObjectType; 
    Instance: PPerfInstanceDefinition; 
    Counter: PPerfCounterDefinition; 
begin 
    Result := 0; 

    Data := GetPerformanceData(IntToStr(ObjProcess)); 
    try 
    Obj := GetObjectByNameIndex(Data, ObjProcess); 
    if not Assigned(Obj) then 
     Exit; 

    Counter := GetCounterByNameIndex(Obj, CtrPrivateBytes); 
    if not Assigned(Counter) then 
     Exit; 

    Instance := GetProcessInstance(Obj, ProcessID); 
    if not Assigned(Instance) then 
     Exit; 

    Result := GetCounterValue64(Obj, Counter, Instance); 
    finally 
    FreeMem(Data); 
    end; 
end; 

function GetProcessThreadCount(ProcessID: Cardinal): Cardinal; 
var 
    Data: PPerfDataBlock; 
    Obj: PPerfObjectType; 
    Instance: PPerfInstanceDefinition; 
    Counter: PPerfCounterDefinition; 
begin 
    Result := 0; 

    Data := GetPerformanceData(IntToStr(ObjProcess)); 
    try 
    Obj := GetObjectByNameIndex(Data, ObjProcess); 
    if not Assigned(Obj) then 
     Exit; 

    Counter := GetCounterByNameIndex(Obj, CtrThreadCount); 
    if not Assigned(Counter) then 
     Exit; 

    Instance := GetProcessInstance(Obj, ProcessID); 
    if not Assigned(Instance) then 
     Exit; 

    Result := GetCounterValue32(Obj, Counter, Instance); 
    finally 
    FreeMem(Data); 
    end; 
end; 

function GetProcessVirtualBytes(ProcessID: Cardinal): UInt64; 
var 
    Data: PPerfDataBlock; 
    Obj: PPerfObjectType; 
    Instance: PPerfInstanceDefinition; 
    Counter: PPerfCounterDefinition; 
begin 
    Result := 0; 

    Data := GetPerformanceData(IntToStr(ObjProcess)); 
    try 
    Obj := GetObjectByNameIndex(Data, ObjProcess); 
    if not Assigned(Obj) then 
     Exit; 

    Counter := GetCounterByNameIndex(Obj, CtrVirtualBytes); 
    if not Assigned(Counter) then 
     Exit; 

    Instance := GetProcessInstance(Obj, ProcessID); 
    if not Assigned(Instance) then 
     Exit; 

    Result := GetCounterValue64(Obj, Counter, Instance); 
    finally 
    FreeMem(Data); 
    end; 
end; 

function GetProcessorCount: Integer; 
var 
    Data: PPerfDataBlock; 
    Obj: PPerfObjectType; 
begin 
    Result := -1; 

    Data := GetPerformanceData(IntToStr(ObjProcessor)); 
    try 
    Obj := GetFirstObject(Data); 
    if not Assigned(Obj) then 
     Exit; 

    Result := Obj^.NumInstances; 
    if Result > 1 then // disregard the additional '_Total' instance 
     Dec(Result); 
    finally 
    FreeMem(Data); 
    end; 
end; 

function GetSystemProcessCount: Cardinal; 
begin 
    Result := GetSimpleCounterValue32(ObjSystem, CtrProcesses); 
end; 

function GetSystemUpTime: TDateTime; 
const 
    SecsPerDay = 60 * 60 * 24; 
var 
    Data: PPerfDataBlock; 
    Obj: PPerfObjectType; 
    Counter: PPerfCounterDefinition; 
    SecsStartup: UInt64; 
begin 
    Result := 0; 

    Data := GetPerformanceData(IntToStr(ObjSystem)); 
    try 
    Obj := GetObjectByNameIndex(Data, ObjSystem); 
    if not Assigned(Obj) then 
     Exit; 

    Counter := GetCounterByNameIndex(Obj, CtrSystemUpTime); 
    if not Assigned(Counter) then 
     Exit; 

    SecsStartup := GetCounterValue64(Obj, Counter); 
    // subtract from snapshot time and divide by base frequency and number of seconds per day 
    // to get a TDateTime representation 
    Result := (Obj^.PerfTime.QuadPart - SecsStartup)/Obj^.PerfFreq.QuadPart/SecsPerDay; 
    finally 
    FreeMem(Data); 
    end; 
end; 

initialization 
    QueryPerformanceFrequency(PerfFrequency); 

finalization 

end. 
+0

Olvidé agregar, esa unidad fue escrita para Delphi 7, así que si quieres usarla en Delphi 2009 o posterior tienes que modificarla un poco para hacerla compatible: cambiar las declaraciones para usar AnsiChar en lugar de Char, PAnsiChar en lugar de PChar, etc. –

Cuestiones relacionadas