systeminfo.pas

得到

  TimerHi, TimerLo: DWORD;
  PriorityClass, Priority: Integer;
begin
  PriorityClass := GetPriorityClass(GetCurrentProcess);
  Priority := GetThreadPriority(GetCurrentThread);

  SetPriorityClass(GetCurrentProcess, REALTIME_PRIORITY_CLASS);
  SetThreadPriority(GetCurrentThread, THREAD_PRIORITY_TIME_CRITICAL);

  Sleep(10);
  asm
    dw 310Fh // rdtsc
    mov TimerLo, eax
    mov TimerHi, edx
  end;
  Sleep(DelayTime);
  asm
    dw 310Fh // rdtsc
    sub eax, TimerLo
    sbb edx, TimerHi
    mov TimerLo, eax
    mov TimerHi, edx
  end;

  SetThreadPriority(GetCurrentThread, Priority);
  SetPriorityClass(GetCurrentProcess, PriorityClass);

  Result := TimerLo / (1000.0 * DelayTime);
end;

const
 ID_BIT  =  $200000;      // EFLAGS ID bit
type
 TCPUID  = array[1..4] of Longint;
 TVendor  = array [0..11] of char;

function IsCPUIDAvailable : Boolean; register;
asm
 PUSHFD              {direct access to flags no possible, only via stack}
  POP     EAX          {flags to EAX}
  MOV     EDX,EAX      {save current flags}
  XOR     EAX,ID_BIT  {not ID bit}
  PUSH    EAX          {onto stack}
  POPFD                {from stack to flags, with not ID bit}
  PUSHFD              {back to stack}
  POP     EAX          {get back to EAX}
  XOR     EAX,EDX      {check if ID bit affected}
  JZ      @exit        {no, CPUID not availavle}
  MOV     AL,True      {Result=True}
@exit:
end;

function GetCPUID : TCPUID; assembler; register;
asm
  PUSH    EBX         {Save affected register}
  PUSH    EDI
  MOV     EDI,EAX     {@Resukt}
  MOV     EAX,1
  DW      $A20F       {CPUID Command}
  STOSD                {CPUID[1]}
  MOV     EAX,EBX
  STOSD               {CPUID[2]}
  MOV     EAX,ECX
  STOSD               {CPUID[3]}
  MOV     EAX,EDX
  STOSD               {CPUID[4]}
  POP     EDI          {Restore registers}
  POP     EBX
end;

function GetCPUVendor : TVendor; assembler; register;
asm
  PUSH    EBX          {Save affected register}
  PUSH    EDI
  MOV     EDI,EAX      {@Result (TVendor)}
  MOV     EAX,0
  DW      $A20F        {CPUID Command}
  MOV     EAX,EBX
  XCHG    EBX,ECX     {save ECX result}
  MOV      ECX,4
@1:
  STOSB
  SHR     EAX,8
  LOOP    @1
  MOV     EAX,EDX
  MOV      ECX,4
@2:
  STOSB
  SHR     EAX,8
  LOOP    @2
  MOV     EAX,EBX
  MOV      ECX,4
@3:
  STOSB
  SHR     EAX,8
  LOOP    @3
  POP     EDI          {Restore registers}
  POP     EBX
end;


Function GetSpesialFolder(Handle:Hwnd;nFolder:Integer):String;
var
 PIDL: PItemIDList;
 Path: LPSTR;
begin
 Result:='';
 Path := StrAlloc(MAX_PATH);
 SHGetSpecialFolderLocation(Handle, nFolder, PIDL);

 if SHGetPathFromIDList(PIDL, Path) then
  Result := StrPas(Path);

// SHGetSpecialFolderPath(Handle,Path,nFolder,False);
// Result:=Path;
 StrDispose(Path);
end;

{*************************************************************}

{*************************************************************}

constructor TKeyboard.Create;
Begin
  inherited Create;
//  RefreshInfo;
End;

destructor TKeyboard.Destroy;
Begin
  inherited Destroy;
End;

Procedure TKeyboard.RefreshInfo;
var  Keys: TKeyboardState;
Begin
 GetKeyboardState( keys );
 FNumLock  := keys[VK_NUMLOCK]=1;
 FCapsLock := keys[VK_CAPITAL]=1;
 FScrollLock := keys[VK_SCROLL]=1;
End;

constructor TDisplay.Create;
Begin
  inherited Create;
  FSupportedModes:=tStringList.Create;
//  RefreshInfo(0);
End;

destructor TDisplay.Destroy;
Begin
  FsupportedModes.Free;
  inherited Destroy;
End;

Procedure TDisplay.RefreshInfo(AdapterIndex:Integer);
var
  Buf        : array [0..3] of byte;
  I          : Integer;
  DevMode : TDevMode;

Function MsgColorDepth(ColorDepth:Integer):String;
Begin
 case ColorDepth of
 2 : result:='Grayscale';
 4 : result:='16 Colors';
 8 : result:='256 Colors';
 16: result:='High Colors';
 24: result:='True Colors';
 End;
End;

Begin
 FsupportedModes.Free;
 FSupportedModes:=tStringList.Create;
 i := 0;
 while EnumDisplaySettings(nil,i,Devmode) do begin
  with Devmode do
  Begin
   FSupportedModes.Add(Format('%d x %d - %s',[dmPelsWidth,dmPelsHeight,MsgColorDepth(dmBitsPerPel)]));
   Inc(i);
  end;
 End;
 with TRegistry.Create do
 Try
  RootKey := HKEY_LOCAL_MACHINE;

  If OpenKey('System\CurrentControlSet\Services\Class\Display\'+FormatFloat('0000',AdapterIndex)+'\INFO', False) then
  Begin
   FChipType:=ReadString('ChipType');
   FDACType:=ReadString('DACType');
   FRevision:=ReadString('Revision');
   FMemory:=Inttostr(ReadInteger('VideoMemory'));
   CloseKey;
  End;

  If OpenKey('System\CurrentControlSet\Services\Class\Display\'+FormatFloat('0000',AdapterIndex)+'\3D', False) then
  Begin
   I           := Readbinarydata ('AGP',buf,sizeof(buf));
   FAGP:=(Buf[0]=1);
   I           := Readbinarydata ('3DP',buf,sizeof(buf));
   F3DProcessor:=(Buf[0]=1);
   CloseKey;
  End;

 Finally
  Free;
 End;
End;

constructor TNetwork.Create;
Begin
  inherited Create;
  FNetProto:=tStringList.Create;
  FNetCli:=tStringList.Create;
  FNetAdap:=tStringList.Create;
//  RefreshInfo;
End;

destructor TNetwork.Destroy;
Begin
  FNetProto.Free;
  FNetCli.Free;
  FNetAdap.Free;
  inherited Destroy;
End;

procedure TNetwork.RefreshInfo;
var
  count:integer;
  wVersionRequested : WORD;
  wsaData : TWSAData;
  p : PHostEnt;
  s : array[0..128] of char;
  p2 : pchar;
begin
 {Start up WinSock}
 wVersionRequested := MAKEWORD(1, 1);
 WSAStartup(wVersionRequested, wsaData);

 {Get the computer name}
 GetHostName(@s, 128);
 p := GetHostByName(@s);
 FLocalHost:=p^.h_Name;
 {Get the IpAddress}

 p2 := iNet_ntoa(PInAddr(p^.h_addr_list^)^);
 FLocalIP:=p2;
 WSACleanup;

 FNetProto.Free;
 FNetProto:=tStringList.Create;
 FNetCli.Free;
 FNetCli:=tStringList.Create;
 FNetAdap.Free;
 FNetAdap:=tStringList.Create;

 with TRegistry.Create do
 Try
  RootKey := HKEY_LOCAL_MACHINE;
  Count:=0;
  While OpenKey('System\CurrentControlSet\Services\Class\Net\'+FormatFloat('0000',Count), False) do
  Begin
   FNetAdap.AddObject(ReadString('DriverDesc'),tObject(ReadString('ProviderName')));
   CloseKey;
   Inc(count);
  End;

  Count:=0;
  While OpenKey('System\CurrentControlSet\Services\Class\NetClient\'+FormatFloat('0000',Count), False) do
  Begin
   FNetCli.AddObject(ReadString('DriverDesc'),tObject(ReadString('ProviderName')));
   CloseKey;
   Inc(count);
  End;

  Count:=0;
  While OpenKey('System\CurrentControlSet\Services\Class\NetTrans\'+FormatFloat('0000',Count), False) do
  Begin
   FNetProto.AddObject(ReadString('DriverDesc'),tObject(ReadString('ProviderName')));
   CloseKey;
   Inc(count);
  End;

 Finally
  Free;
 End;

End;

constructor TDirectX.Create;
Begin
  inherited Create;
  FDirect3dDrvDesc:=tStringList.Create;
  FDirectMusicDrvDesc:=tstringList.Create;
  FDirectPlayDrvDesc:=tstringList.Create;
//  RefreshInfo;
End;

destructor TDirectX.Destroy;
Begin
  FDirect3dDrvDesc.Free;
  FDirectMusicDrvDesc.Free;
  FDirectPlayDrvDesc.Free;
  inherited Destroy;
End;

procedure TDirectX.RefreshInfo;
var Key : tstrings;
    I   : Integer;
Begin
 FDirect3dDrvDesc.Free;
 FDirect3dDrvDesc:=tStringList.Create;
 FDirectMusicDrvDesc.Free;
 FDirectMusicDrvDesc:=tstringList.Create;
 FDirectPlayDrvDesc.Free;
 FDirectPlayDrvDesc:=tstringList.Create;
 Key:=tstringList.Create;
 with TRegistry.Create do
 Try
  RootKey := HKEY_LOCAL_MACHINE;

  if OpenKey('Software\Microsoft\DirectX', False) then
  Begin
   FVersion:=ReadString('Version');
   CloseKey;
  End;

  { Getting Direct3D Driver Description }
  if OpenKey('Software\Microsoft\Direct3D\Drivers', False) then
  Begin
   GetKeynames(Key);
   CloseKey;
  End;

  For I:=0 to Key.count-1 do
  Begin
   if OpenKey('Software\Microsoft\Direct3D\Drivers\'+Key.Strings[I], False) then
   Begin
    FDirect3dDrvDesc.Add(ReadString('Description'));
    CloseKey;
   End;
  end;

  { Getting DirectMusic Description }
  if OpenKey('Software\Microsoft\DirectMusic\SoftwareSynths', False) then
  Begin
   GetKeynames(Key);
   CloseKey;
  End;

  For I:=0 to Key.count-1 do
  Begin
   if OpenKey('Software\Microsoft\DirectMusic\SoftwareSynths\'+Key.Strings[I], False) then
   Begin
    FDirectMusicDrvDesc.Add(ReadString('Description'));
    CloseKey;
   End;
  end;
  
  { Getting DirectPlay Description }
  if OpenKey('Software\Microsoft\DirectPlay\Services', False) then
  Begin
   GetKeynames(Key);
   CloseKey;
  End;

  For I:=0 to Key.count-1 do
  Begin
   if OpenKey('Software\Microsoft\DirectPlay\Services\'+Key.Strings[I], False) then
   Begin
    FDirectPlayDrvDesc.Add(ReadString('Description'));
    CloseKey;
   End;
  end;
  
 Key.Free;
 Finally
  Free;
 End;
End;

constructor TDevice.Create;
Begin
 inherited Create;
 FHDC:=TstringList.Create;
 FFDC:=tStringList.create;
 FMultiFun:=TstringList.Create;
 FInfraRed:=tstringList.create;
 FPCMCIA:=tStringList.Create;
 FCDROM:=tStringList.Create;
 F3dAccel:=tStringList.Create;
 FMouse:=tStringList.Create;
 FKeyboard:=tStringList.Create;
 FModem:=tstringList.Create;
 FMonitor:=tstringList.Create;
 FSCSI:=tstringList.Create;
 FPrinter:=tstringList.Create;
 FMedia:=tstringList.Create;
 FAdapter:=tStringList.Create;
 FSystem:=TStringList.Create;
 FUSB:=tStringList.Create;
 FPorts:=tStringList.Create;
//  RefreshInfo;
End;

destructor TDevice.Destroy;
Begin
 FHDC.Free;
 FFDC.Free;;
 FMultiFun.Free;
 FInfraRed.Free;