Home


Delphi - GetTickCountEx

 ////////////////////////////////////////////////////////////////////////////////
//
//  GetSystemUpTimeNt()
//
//    Uses the registry interface to get the value of the performance counter
//    '\\localhost\System\System Up Time' in milliseconds (returns 0 on error).
//

function GetSystemUpTimeNt(): Int64;
{$IFDEF WIN32}
type
  PPerfDataBlock = ^TPerfDataBlock;
  TPerfDataBlock = packed record
    Signature       : array [0..3] of WCHAR;
    LittleEndian    : DWORD;
    Version         : DWORD;
    Revision        : DWORD;
    TotalByteLength : DWORD;
    HeaderLength    : DWORD;
    NumObjectTypes  : DWORD;
    DefaultObject   : DWORD;
    SystemTime      : SYSTEMTIME;
    PerfTime        : LARGE_INTEGER;
    PerfFreq        : LARGE_INTEGER;
    PerfTime100nSec : LARGE_INTEGER;
    SystemNameLength: DWORD;
    SystemNameOffset: DWORD;
  end;
  PPerfObjectType = ^TPerfObjectType;
  TPerfObjectType = packed record
    TotalByteLength     : DWORD;
    DefinitionLength    : DWORD;
    HeaderLength        : DWORD;
    ObjectNameTitleIndex: DWORD;
    ObjectNameTitle     : LPWSTR;
    ObjectHelpTitleIndex: DWORD;
    ObjectHelpTitle     : LPWSTR;
    DetailLevel         : DWORD;
    NumCounters         : DWORD;
    DefaultCounter      : DWORD;
    NumInstances        : DWORD;
    CodePage            : DWORD;
    PerfTime            : LARGE_INTEGER;
    PerfFreq            : LARGE_INTEGER;
  end;
  PPerfCounterDefinition = ^TPerfCounterDefinition;
  TPerfCounterDefinition = packed record
    ByteLength           : DWORD;
    CounterNameTitleIndex: DWORD;
    CounterNameTitle     : LPWSTR;
    CounterHelpTitleIndex: DWORD;
    CounterHelpTitle     : LPWSTR;
    DefaultScale         : DWORD;
    DetailLevel          : DWORD;
    CounterType          : DWORD;
    CounterSize          : DWORD;
    CounterOffset        : DWORD;
  end;
  PPerfInstanceDefinition = ^TPerfInstanceDefinition;
  TPerfInstanceDefinition = packed record
    ByteLength            : DWORD;
    ParentObjectTitleIndex: DWORD;
    ParentObjectInstance  : DWORD;
    UniqueID              : DWORD;
    NameOffset            : DWORD;
    NameLength            : DWORD;
  end;
  PLARGE_INTEGER = ^LARGE_INTEGER;
const
  PERF_SIZE_LARGE      = $00000100;
  PERF_TYPE_COUNTER    = $00000400;
  PERF_COUNTER_ELAPSED = $00040000;
  PERF_OBJECT_TIMER    = $00200000;
  PERF_DISPLAY_SECONDS = $30000000;
  PERF_ELAPSED_TIME    = PERF_SIZE_LARGE or PERF_TYPE_COUNTER or
                         PERF_COUNTER_ELAPSED or PERF_OBJECT_TIMER or
                         PERF_DISPLAY_SECONDS;
  PERF_NO_INSTANCES = DWORD(-1);
var
  ValSize: DWORD;
  Counter: PChar;
  CurrIdx: PChar;
  CurrStr: PChar;
  CntrStr: PChar;
  CntrSys: DWORD;
  CntrSUT: DWORD;
  QrySize: DWORD;
  QryData: PPerfDataBlock;
  CurrObj: PPerfObjectType;
  ObjLoop: DWORD;
  CurrDef: PPerfCounterDefinition;
  DefLoop: DWORD;
  ObjInst: PPerfInstanceDefinition;
  CntrVal: PLARGE_INTEGER;
{$ENDIF}
begin
  Result := 0;  // indicates failure
{$IFDEF WIN32}
  ValSize := 0;
  if (RegQueryValueEx(HKEY_PERFORMANCE_DATA, 'Counter 009', nil, nil, nil,
    @ValSize) = ERROR_SUCCESS) then
  try
    Inc(ValSize, 1024);
    Counter := GetMemory(ValSize);
    if (Counter <> nil) then
    try
      if (RegQueryValueEx(HKEY_PERFORMANCE_DATA, 'Counter 009', nil, nil,
        PByte(Counter), @ValSize) = ERROR_SUCCESS) then
      begin
        CntrStr := nil;
        CntrSys := 0;
        CntrSUT := 0;
        CurrIdx := Counter;
        while (CurrIdx[0] <> #0) do
        begin
          CurrStr := PChar(@CurrIdx[StrLen(CurrIdx) + 1]);
          if ((CntrSys = 0) and (StrComp(CurrStr, 'System') = 0)) then
          begin
            CntrStr := CurrIdx;
            CntrSys := StrToInt(string(CurrIdx));
            if (CntrSUT <> 0) then
              Break;
          end;
          if ((CntrSUT = 0) and (StrComp(CurrStr, 'System Up Time') = 0)) then
          begin
            CntrSUT := StrToInt(string(CurrIdx));
            if (CntrSys <> 0) then
              Break;
          end;
          CurrIdx := PChar(@CurrStr[StrLen(CurrStr) + 1]);
        end;
        if ((CntrStr <> nil) and (CntrSys <> 0) and (CntrSUT <> 0)) then
        begin
          QrySize := 0;
          QryData := nil;
          try
            repeat
              Inc(QrySize, 4096);
              QryData := ReallocMemory(QryData, QrySize);
              if (QryData = nil) then
                Break;
              ValSize := QrySize;
            until (RegQueryValueEx(HKEY_PERFORMANCE_DATA, CntrStr, nil, nil,
              PByte(QryData), @ValSize) <> ERROR_MORE_DATA);
            if ((ValSize > 0) and (QryData <> nil)) then
              if (QryData.Signature = 'PERF') then
              begin
                CurrObj := PPerfObjectType(Cardinal(QryData) +
                  QryData.HeaderLength);
                for ObjLoop := 1 to QryData.NumObjectTypes do
                begin
                  if ((CurrObj.ObjectNameTitleIndex = CntrSys) and
                    (CurrObj.NumInstances > 0) and
                    (CurrObj.PerfFreq.QuadPart >= 1000)) then
                  begin
                    CurrDef := PPerfCounterDefinition(Cardinal(CurrObj) +
                      CurrObj.HeaderLength);
                    for DefLoop := 1 to CurrObj.NumCounters do
                    begin
                      if (CurrDef.CounterNameTitleIndex = CntrSUT) and
                        (CurrDef.CounterType = PERF_ELAPSED_TIME) then
                      begin
                        if (CurrObj.NumInstances = PERF_NO_INSTANCES) then
                          CntrVal := PLARGE_INTEGER(Cardinal(CurrObj) +
                             CurrObj.DefinitionLength + CurrDef.CounterOffset)
                        else
                        begin
                          // first instance
                          ObjInst := PPerfInstanceDefinition(Cardinal(CurrObj) +
                            CurrObj.DefinitionLength);
                          CntrVal := PLARGE_INTEGER(Cardinal(ObjInst) +
                             ObjInst.ByteLength + CurrDef.CounterOffset);
                        end;
                        Result :=
                          (CurrObj.PerfTime.QuadPart - CntrVal.QuadPart) div
                          (CurrObj.PerfFreq.QuadPart div 1000);  // milliseconds
                        Break;
                      end;
                      CurrDef := PPerfCounterDefinition(Cardinal(CurrDef) +
                        CurrDef.ByteLength);
                    end;
                    Break;
                  end;
                  CurrObj := PPerfObjectType(Cardinal(CurrObj) +
                    CurrObj.TotalByteLength);
                end;
              end;
          finally
            if (QryData <> nil) then
              FreeMemory(QryData);
          end;
        end;
      end;
    finally
      FreeMemory(Counter);
    end;
  finally
    RegCloseKey(HKEY_PERFORMANCE_DATA);
  end;
{$ENDIF}
end;

////////////////////////////////////////////////////////////////////////////////
//
//  GetSystemUpTime9x()
//
//    Uses GetTickCount() to get the 'System Up Time' in milliseconds.
//    Will wrap around to zero if the system is run continuously for 49.7 days!
//

function GetSystemUpTime9x(): Int64;
begin
{$IFDEF WIN32}
  Result := GetTickCount();
{$ELSE}
  Result := 0;
{$ENDIF}
end;

////////////////////////////////////////////////////////////////////////////////
//
//  GetSystemUpTime()
//
//    Wrapper for GetSystemUpTimeNt() and GetSystemUpTime9x()
//

function GetSystemUpTime(): Int64;
begin
  Result := GetSystemUpTimeNt();
  if (Result = 0) then
    Result := GetSystemUpTime9x();
end;


procedure TForm1.Button1Click(Sender: TObject);
var
  UpTimeNt: Int64;
  UpTime9x: Int64;
begin
  UpTime9x := GetSystemUpTime9x();
  UpTimeNt := GetSystemUpTimeNt();
  ShowMessage(Format('GetTickCount: %d day(s) %2.2d:%2.2d:%2.2d.%3.3d'#10 +
    'Perf-Counter: %d day(s) %2.2d:%2.2d:%2.2d.%3.3d', [UpTime9x div 86400000,
    UpTime9x mod 86400000 div 3600000, UpTime9x mod 3600000 div 60000,
    UpTime9x mod 60000 div 1000, UpTime9x mod 1000, UpTimeNt div 86400000,
    UpTimeNt mod 86400000 div 3600000, UpTimeNt mod 3600000 div 60000,
    UpTimeNt mod 60000 div 1000, UpTimeNt mod 1000]));
end;

 

Nico Bendlin


2012-01-26T23:14:40 +0100