Fórum Biblioteca HID #585846

unit HID;

interface
uses
  Windows, Messages, Classes, Controls, Forms, sysutils,Registry,
  Dialogs, TLHelp32, ExtCtrls, Math;
type
   THardwareget = Record
   FGet: String;
end;
Var
   FileSystemFlags, MaximumComponentLength, VolumeSerialNumber: DWORD;
   CPUID: String;
   CPUType: String;
   CPUModel: String;
   CPUSpeed: String;
   Biosdate: String;
   VideoBiosdate: String;
   HDDManufactur: String;
   HDDSerialNo: String;
   HDDVSerialNo: String;
   Windir: String;
   TempDir: String;
   ProgramFilesDir: String;
   ScreenResolution: String;
   MemTotalPhisical: String;
   Wintype: String;
   WinProductId: String;
   WinUserName: String;
   SerialNo: String;
   FHardwareID: String;
   Reg: TRegistry;
   procedure GetHardwareID;
implementation

Function GetHDSerialNumber: LongInt;
{$IFDEF WIN32}
var
  Pdw : pDWord;
  Mc, Fl : dword;
{$ENDIF}
begin
  {$IfDef WIN32}
  New(Pdw);
  GetVolumeInformation('C:\\', nil, 0, Pdw, Mc, Fl, nil, 0);
  Result := pdw^;
  dispose(Pdw);
  {$ELSE}
  Result := GetWinFlags;
  {$ENDIF}
end;
Function GetProgramFilesDir: String;
var
  Reg: TRegistry;
Begin
  Reg := TRegistry.Create;
  Try
    Reg.RootKey := HKEY_LOCAL_MACHINE;
    Reg.OpenKey('SOFTWARE\\Microsoft\\Windows\\CurrentVersion', False);
    Result := Reg.ReadString('ProgramFilesDir');
  Finally
    Reg.Free;
  end;
end;
Function GetUser: String;
var
  Buffer: String;
  BuffSize: DWORD;
Begin
  BuffSize := 128;
  Setlength(Buffer, BuffSize);
  GetUserName(PChar(Buffer), BuffSize);
  Result := Trim(Buffer);
end;
Function GetCPUSpeed: Double;
const
  DelayTime = 500;
var
  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);
  Result := Floor(Result);
end;
Function GetIdeSerialNumber:String;
const
  IDENTIFY_BUFFER_SIZE = 512;
type
  TIDERegs = packed record
    bFeaturesReg     : BYTE; // Used for specifying SMART "commands".
    bSectorCountReg  : BYTE; // IDE sector count register
    bSectorNumberReg : BYTE; // IDE sector number register
    bCylLowReg       : BYTE; // IDE low order cylinder value
    bCylHighReg      : BYTE; // IDE high order cylinder value
    bDriveHeadReg    : BYTE; // IDE drive/head register
    bCommandReg      : BYTE; // Actual IDE command.
    bReserved        : BYTE; // reserved for future use.  Must be zero.
  end;
  TSendCmdInParams = packed record
    cBufferSize  : DWORD;
    irDriveRegs  : TIDERegs;
    bDriveNumber : BYTE;
    bReserved    : Array[0..2] of Byte;
    dwReserved   : Array[0..3] of DWORD;
    bBuffer      : Array[0..0] of Byte;  // Input buffer.
  end;
  TIdSector = packed record
    wGenConfig                 : Word;
    wNumCyls                   : Word;
    wReserved                  : Word;
    wNumHeads                  : Word;
    wBytesPerTrack             : Word;
    wBytesPerSector            : Word;
    wSectorsPerTrack           : Word;
    wVendorUnique              : Array[0..2] of Word;
    sSerialNumber              : Array[0..19] of CHAR;
    wBufferType                : Word;
    wBufferSize                : Word;
    wECCSize                   : Word;
    sFirmwareRev               : Array[0..7] of Char;
    sModelNumber               : Array[0..39] of Char;
    wMoreVendorUnique          : Word;
    wDoubleWordIO              : Word;
    wCapabilities              : Word;
    wReserved1                 : Word;
    wPIOTiming                 : Word;
    wDMATiming                 : Word;
    wBS                        : Word;
    wNumCurrentCyls            : Word;
    wNumCurrentHeads           : Word;
    wNumCurrentSectorsPerTrack : Word;
    ulCurrentSectorCapacity    : DWORD;
    wMultSectorStuff           : Word;
    ulTotalAddressableSectors  : DWORD;
    wSingleWordDMA             : Word;
    wMultiWordDMA              : Word;
    bReserved                  : Array[0..127] of BYTE;
  end;
  PIdSector = ^TIdSector;
  TDriverStatus = packed record
    bDriverError : Byte;
    bIDEStatus   : Byte;
    bReserved    : Array[0..1] of Byte;
    dwReserved   : Array[0..1] of DWORD;
  end;
  TSendCmdOutParams = packed record
    cBufferSize  : DWORD;
    DriverStatus : TDriverStatus;
    bBuffer      : Array[0..0] of BYTE;
  end;
  var
    hDevice : THandle;
    cbBytesReturned : DWORD;
    ptr : PChar;
    SCIP : TSendCmdInParams;
    aIdOutCmd : Array [0..(SizeOf(TSendCmdOutParams)+IDENTIFY_BUFFER_SIZE-1)-1] of Byte;
    IdOutCmd  : TSendCmdOutParams absolute aIdOutCmd;
  procedure ChangeByteOrder( var Data; Size : Integer );
  var
    Ptr: PChar;
    I: Integer;
    C: Char;
  Begin
    Ptr := @Data;
    For I := 0 to (Size shr 1) - 1 Do
    Begin
      C := Ptr^;
      Ptr^ := (Ptr + 1)^;
      (Ptr + 1)^ := C;
      Inc(Ptr, 2);
    end;
  end;

Begin
  Result := ''; // return empty String on error
  If SysUtils.Win32Platform = VER_PLATFORM_WIN32_NT then // Windows NT, Windows 2000
  begin
    hDevice := CreateFile( '\\\\.\\PhysicalDrive0', GENERIC_READ or GENERIC_WRITE,
      FILE_SHARE_READ or FILE_SHARE_WRITE, nil, OPEN_EXISTING, 0, 0 );
  end
  Else // Version Windows 95 OSR2, Windows 98
    hDevice := CreateFile( '\\\\.\\SMARTVSD', 0, 0, nil, CREATE_NEW, 0, 0 );
  If hDevice=INVALID_HANDLE_VALUE Then Exit;
  Try
    FillChar(SCIP,SizeOf(TSendCmdInParams)-1,#0);
    FillChar(aIdOutCmd,SizeOf(aIdOutCmd),#0);
    cbBytesReturned := 0;
    With SCIP Do
    Begin
      cBufferSize  := IDENTIFY_BUFFER_SIZE;
      With irDriveRegs Do
      Begin
        bSectorCountReg  := 1;
        bSectorNumberReg := 1;
        bDriveHeadReg    := $A0;
        bCommandReg      := $EC;
      end;
    end;
    If not DeviceIoControl( hDevice, $0007c088, @SCIP, SizeOf(TSendCmdInParams) - 1,
      @aIdOutCmd, SizeOf(aIdOutCmd), cbBytesReturned, nil) Then Exit;
  Finally
    CloseHandle(hDevice);
  end;
  With PIdSector(@IdOutCmd.bBuffer)^ Do
  Begin
    ChangeByteOrder( sSerialNumber, SizeOf(sSerialNumber) );
    (PChar(@sSerialNumber)+SizeOf(sSerialNumber))^ := #0;
    Result := PChar(@sSerialNumber);
  end;
end;

Procedure GetHardwareID;
var
  A, B, C, D: LongWord;
  uretici: Array [0..3] of Dword;
  x: PChar;
  sysdir: Array[0..144] of Char;
  temp_klasor: Array[0..MAX_PATH] of Char;
  MS: TMemoryStatus;
  Reg: TRegistry;
  yyil: String;
begin
  Try
    asm
      mov eax,1 // eax registeri cpuid komutunun parametresidir
      db $0F, $A2 // cpuid komutu
      mov a,EAX
      mov b,EBX
      mov c,ECX
      mov d,EDX
    end;
    CPUID := IntToHex(A, 8) + '-' + IntToHex(B, 8) + '-' + IntToHex(C, 8) + '-' + IntToHex(D, 8);
   Except
    CPUID := 'ERRO!'; //'0000-D342-F921-M068';
   end;
  Try
    asm
      push ebx
      mov  eax, 0
      dw $A20F // CPUID
      mov DWord ptr uretici, ebx //
      mov DWord ptr uretici[+4], edx // üretici dizisinin ikinci elemanýný al
      mov Dword ptr uretici[+8], ecx
      pop ebx
    end;
    uretici[3] := 0;
    x := @uretici;
    CPUType := x;
  Except
    CPUType := 'ERRO!'; //'GenuineIntel';
  end;
   Try
     Reg := TRegistry.Create;
     Reg.RootKey := HKEY_LOCAL_MACHINE;
     Reg.OpenKey('\\Hardware\\Description\\System\\CentralProcessor\\0', True);
     CPUModel := Reg.ReadString('Identif