type

TRegistryRO = class (TRegistry)

  function OpenKeyRO (const Key: string): Boolean;

 end;

{ это уже ветхая история - был один глюк у D3}

implementation

uses WAPIInfo, Windows, SysUtils, StrUtils;

function TRegistryRO.OpenKeyRO (const Key: string): Boolean;

function

IsRelative(const Value: string): Boolean;

 begin Result := not ((Value <> '') and (Value[1] = '\')) end;

var

 TempKey: HKey;

 S: string;

 Relative: Boolean;

begin

 S := Key;

 Relative := IsRelative(S);

 if not Relative then Delete(S, 1, 1);

 TempKey := 0;

  Result := RegOpenKeyEx(GetBaseKey(Relative), PChar(S), 0,

  KEY_READ, TempKey) = ERROR_SUCCESS;

  if Result then begin

  if (CurrentKey <> 0) and Relative then S := CurrentPath + '\' + S;

  ChangeKey(TempKey, S);

  end;

end;

function GetBIOSDate : string;

const

 BIOSDatePtr

= $0ffff5;

 SystemKey = 'HARDWARE\DESCRIPTION\System';

 BiosDateParam = 'SystemBiosDate';

var

 p : pointer;

 s : string[128];

begin

 if OSisNT then begin

  with TRegistryRO.Create do try

  RootKey := HKEY_LOCAL_MACHINE;

  if OpenKeyRO (SystemKey) then begin

  s := ReadString (BiosDateParam);

  end;

  finally Free;

  end; { of try}

  end

  else try

  s[0] := #8;

  p := Pointer(BIOSDatePtr);

  Move (p^, s[1], 8);

  except FillChar (s[1],

8, '9');

  end; { of try}

 Result := copy (s, 1, 2) + copy (s, 4, 2) + copy (s, 7, 2);

end;

function GetVideoDate : string;

const

 VideoDatePtr = $0C0000;

 SystemKey = 'HARDWARE\DESCRIPTION\System';

 VideoDateParam = 'VideoBiosDate';

var

 p : pointer;

 s : string[255];

begin

 if OSisNT then begin

  with TRegistryRO.Create do try

  RootKey := HKEY_LOCAL_MACHINE;

  if OpenKeyRO (SystemKey)

  then s := ReadString (VideoDateParam)

  else s := 'NT/de/tected';

  finally Free;

  end; { of

try}

  end

  else try

  s[0] := #255;

  p := Pointer(VideoDatePtr + 60); { первые $60 - строка CopyRight}

  Move (p^, s[1], 255);

  if pos('/', s) > 2 then s := copy (s, pos('/', s) - 2, 8)

  else begin

  p := Pointer(VideoDatePtr + 60 + 250);

  Move (p^, s[1], 255);

  if pos('/', s) > 2 then s := copy (s, pos('/', s) - 2, 8);

  end;

  except FillChar (s[1], 8, '9');

  end; { of try}

 Result := copy (s, 1, 2) + copy (s, 4, 2) + copy (s, 7, 2);

end;

unit WAPIInfo;

interface

uses

Registry, SysUtils, Windows;

procedure GetOSVerInfo (var OSID : DWORD; var OSStr : string);

function OSisNT : boolean;

procedure GetCPUInfo (var CPUID : DWORD; var CPUStr : string);

procedure GetMemInfo (var MemStr : string);

implementation

procedure GetOSVerInfo (var OSID : DWORD; var OSStr : string);

var

 OSVerInfo : TOSVersionInfo;

 Reg : TRegistry;

 s : string;

begin

 OSVerInfo.dwOSVersionInfoSize := SizeOf (OSVerInfo);

 GetVersionEx (OSVerInfo);

 OSID := OSVerInfo.dwPlatformID;

 case OSID of

  VER_PLATFORM_WIN32S : OSStr := 'Windows 3+';

  VER_PLATFORM_WIN32_WINDOWS : OSStr := 'Windows 95+';

  VER_PLATFORM_WIN32_NT : begin

  OSStr := 'Windows NT';

  Reg := TRegistry.Create;

  Reg.RootKey := HKEY_LOCAL_MACHINE;

  if Reg.OpenKey ('SYSTEM\CurrentControlSet\Control\', False)

  then try

  s := Reg.ReadString ('ProductOptions')

  except s := ''

  end;

  if s = 'WINNT' then OSStr := OSStr + ' WorkStation'

  else if s = 'SERVERNT' then OSStr := OSStr + ' Server 3.5 & hi'

  else if s = 'LANMANNT' then OSStr := OSStr + ' Advanced server 3.1';

  Reg.Free;

 end;

  end;

 with OSVerInfo do OSStr := OSStr + Format (' %d.%d (выпуск %d)',

  [dwMajorVersion, dwMinorVersion, LoWord(dwBuildNumber)]);

end;

function OSisNT : boolean;

var

 s : string;

 i : DWORD;

begin

 GetOSVerInfo (i, s);

 Result := (i = VER_PLATFORM_WIN32_NT);

end;

procedure GetCPUInfo (var CPUID : DWORD; var CPUStr : string);

var SI : TSystemInfo;

begin

 GetSystemInfo (SI);

 CPUID := SI.dwProcessorType;

 case CPUID of

  386: CPUStr := '80386-совместимый процессор';

  486: CPUStr := '80486-совместимый процессор';

  586: CPUStr := 'Pentium-совместимый процессор';

 else CPUStr := 'Неизвестный процессор';

  end;

{ case SI.wProcessorArchitecture of

  PROCESSOR_ARCHITECTURE_INTEL: ;

  MIPS

  ALPHA

  PPC

  UNKNOWN

  end;}

end;

procedure GetMemInfo (var MemStr : string);

var MemInfo : TMemoryStatus;

begin

 MemInfo.dwLength := SizeOf (MemInfo);

 GlobalMemoryStatus (MemInfo);

 with MemInfo do MemStr := Format ('ОЗУ: %0.2f M (свободно %0.2f M)'#$d+

  ' Файл подкачки: %0.2f M (свободно: %0.2f M)'#$d,

  [(dwTotalPhys div 1024) / 1024,

  (dwAvailPhys div 1024) / 1024,

  (dwTotalPageFile div 1024) / 1024,

  (dwAvailPageFile div 1024) / 1024]);

end;

end.