hackbard: Get CPU & Disk Information

function Format(fmt: string; params: array of const): string;
var
  pdw1,
    pdw2: PDWORD;
  i: integer;
  pc: PCHAR;
begin
  pdw1 := nil;

  if High(params) >= 0 then
    GetMem(pdw1, (High(params) + 1) * sizeof(Pointer));

  pdw2 := pdw1;
  for i := 0 to High(params) do
  begin
    pdw2^ := PDWORD(@params[i])^;
    inc(pdw2);
  end;

  pc := GetMemory(1024);
  if Assigned(pc) then
  try
    SetString(Result, pc, wvsprintf(pc, PCHAR(fmt), PCHAR(pdw1)));
  finally
    if (pdw1 <> nil) then
      FreeMem(pdw1);
    FreeMem(pc);
  end
  else
    Result := '';
end;

function IntToStr(Int: integer): string;
begin
  Result := Format('%d', [Int]);
end;

function UpperCase(const s: string): string;
var
  i: integer;
begin
  Result := '';

  if (length(s) > 0) then
  begin
    SetLength(Result, length(s));
    for i := 1 to length(s) do
      Result[i] := UpCase(s[i]);
  end;
end;

function TrimSpaces(const s: string): string;
var
  iLen: integer;
begin
  Result := s;

  if (Result[length(Result)] = #32) then
  begin
    iLen := length(Result);
    while (iLen > 0) and (Result[iLen] = #32) do
      dec(iLen);

    SetLength(Result, iLen);
  end;
end;

const
  APPNAME = 'SysInfo TEST';
  VER = '0.3'; // :o)

  CPUREGPATH = 'Hardware\Description\System\CentralProcessor\0';
  REGDRIVESPATH: array[boolean] of string =
  ('Enum', 'HARDWARE\DEVICEMAP\Scsi');
  ROOTPATH_9x: array[1..2] of string =
  ('ESDI', 'SCSI');

var
  WinNT: boolean = false;

function GetCPUFromReg: string;
const
  szNameString: array[1..3] of string =
  ('ProcessorNameString', 'Identifier', 'VendorIdentifier');
var
  hReg: HKEY;
  cbData,
    lpType: DWORD;
  i: integer;
begin
  Result := '';
  lpType := REG_SZ;

  if (RegOpenKeyEx(HKEY_LOCAL_MACHINE, CPUREGPATH, 0, KEY_READ, hReg) =
    ERROR_SUCCESS) then
  try
    for i := 1 to length(szNameString) do
      if (RegQueryValueEx(hReg, pchar(szNameString[i]), nil, @lpType,
        nil, @cbData) = ERROR_SUCCESS) and (cbData > 0) then
      begin
        SetLength(Result, cbData);

        if (RegQueryValueEx(hReg, pchar(szNameString[i]), nil, @lpType,
          @Result[1], @cbData) = ERROR_SUCCESS) then
        begin
          SetLength(Result, cbData - 1);
          break;
        end
        else
          Result := '';
      end;
  finally
    RegCloseKey(hReg);
  end;
end;

function GetCPUSpeedFromReg: DWORD;
var
  hReg: HKEY;
  cbData,
    lpType: DWORD;
begin
  result := 0;
  lpType := REG_DWORD;

  if RegOpenKeyEx(HKEY_LOCAL_MACHINE, CPUREGPATH, 0, KEY_READ, hReg) =
    ERROR_SUCCESS then
  try
    if (RegQueryValueEx(hReg, '~MHz', nil, @lpType, nil,
      @cbData) = ERROR_SUCCESS) and (cbData > 0) then
    begin
      RegQueryValueEx(hReg, '~MHz', nil, nil, @result, @cbData);
    end;
  finally
    RegCloseKey(hReg);
  end;
end;

type
  TScsiPorts = array of string;
  TTargetIDArray = array of string;
  TLogicalUnitIDs = array of string;

function GetScsiPorts: TScsiPorts;
var
  hReg,
    sReg: HKEY;
  retCode: integer;
  szBuffer: array[0..MAX_PATH] of Char;
  dwlen: DWORD;
  i,
    j: integer;
begin
  SetLength(Result, 0);

  if (RegOpenKeyEx(HKEY_LOCAL_MACHINE, pchar(REGDRIVESPATH[WinNT]),
    0, KEY_READ, hReg) = ERROR_SUCCESS) then
  try
    if (WinNT) then
    begin
      i := 0;
      repeat
        ZeroMemory(@szBuffer, sizeof(szBuffer));
        dwlen := sizeof(szBuffer);
        retCode := RegEnumKeyEx(hReg, i, szBuffer, dwlen, nil, nil, nil, nil);

        if (retCode = ERROR_SUCCESS) then
        begin
          SetLength(Result, length(Result) + 1);
          Result[length(Result) - 1] := string(szBuffer);
        end;

        inc(i);
      until (retCode = ERROR_NO_MORE_ITEMS);
    end
    else
    begin
      for j := 1 to length(ROOTPATH_9x) do
      begin
        if (RegOpenKeyEx(hReg, pchar(ROOTPATH_9x[j]), 0, KEY_READ,
          sReg) = ERROR_SUCCESS) then
        try
          i := 0;
          repeat
            ZeroMemory(@szBuffer, sizeof(szBuffer));
            dwlen := sizeof(szBuffer);
            retCode := RegEnumKeyEx(sReg, i, szBuffer, dwlen, nil, nil, nil,
              nil);

            if (retCode = ERROR_SUCCESS) then
            begin
              SetLength(Result, length(Result) + 1);
              Result[length(Result) - 1] := ROOTPATH_9x[j] + '\' +
                string(szBuffer);
            end;

            inc(i);
          until (retCode = ERROR_NO_MORE_ITEMS);
        finally
          RegCloseKey(sReg);
        end;
      end;
    end;
  finally
    RegCloseKey(hReg);
  end;
end;

function GetTargetIDs(ScsiPort: string): TTargetIDArray;
const
  szRegPath: array[boolean] of string =
  ('%s\%s', '%s\%s\Scsi Bus 0');
var
  hReg: HKEY;
  retCode: integer;
  szBuffer: array[0..MAX_PATH] of Char;
  dwlen: DWORD;
  i: integer;
begin
  SetLength(Result, 0);

  if (RegOpenKeyEx(HKEY_LOCAL_MACHINE,
    pchar(Format(szRegPath[WinNT], [REGDRIVESPATH[WinNT], ScsiPort])), 0,
    KEY_READ, hReg) = ERROR_SUCCESS) then
  try
    i := 0;
    repeat
      ZeroMemory(@szBuffer, sizeof(szBuffer));
      dwlen := sizeof(szBuffer);
      retcode := RegEnumKeyEx(hReg, i, szBuffer, dwlen, nil, nil, nil, nil);

      if (retcode = ERROR_SUCCESS) then
      begin
        if ((WinNT) and (pos('Target', string(szBuffer)) = 1)) or
          (not WinNT) then
        begin
          SetLength(Result, length(Result) + 1);
          Result[length(Result) - 1] := Format(szRegPath[WinNT] + '\%s',
            [REGDRIVESPATH[WinNT], ScsiPort, string(szBuffer)]);
        end;
      end;

      inc(i);
    until (retcode = ERROR_NO_MORE_ITEMS);
  finally
    RegCloseKey(hReg);
  end;
end;

function GetLogicalUnitIDs(TargetID: string): TLogicalUnitIDs;
var
  hReg: HKEY;
  retCode: integer;
  szBuffer: array[0..MAX_PATH] of char;
  dwlen: DWORD;
  i: integer;
begin
  SetLength(Result, 0);

  // unter Win 98 bin ich schon am Ziel;
  // also nur ein bisschen "so tun als ob ...", um
  // die Programmstruktur nicht ändern zu müssen
  // :o)
  if (not WinNT) then
  begin
    SetLength(Result, length(Result) + 1);
    Result[length(Result) - 1] := TargetID;
  end
  else
  begin
    if (RegOpenKeyEx(HKEY_LOCAL_MACHINE, pchar(TargetId), 0, KEY_READ,
      hReg) = ERROR_SUCCESS) then
    try
      i := 0;
      repeat
        ZeroMemory(@szBuffer, sizeof(szBuffer));
        dwlen := sizeof(szBuffer);
        retCode := RegEnumKeyEx(hReg, i, szBuffer, dwlen, nil, nil, nil, nil);

        if (retCode = ERROR_SUCCESS) and
          (lstrlen(szBuffer) > 0) then
        begin
          SetLength(Result, length(Result) + 1);
          Result[length(Result) - 1] := TargetID + '\' + string(szBuffer);
        end;

        Inc(i);
      until (retCode = ERROR_NO_MORE_ITEMS);
    finally
      RegCloseKey(hReg);
    end;
  end;
end;

function GetDrivesFromReg(RegPath: string): string;
const
  szTypeString: array[boolean] of string =
  ('Class', 'Type');
  szIdString: array[boolean] of string =
  ('DeviceDesc', 'Identifier');
var
  hReg: HKEY;
  sDriveType: string;
  szBuffer: array[0..255] of char;
  cbData: integer;
  lpType: DWORD;
begin
  if (RegOpenKeyEx(HKEY_LOCAL_MACHINE, pchar(RegPath), 0, KEY_READ,
    hReg) = ERROR_SUCCESS) then
  try
    lpType := REG_SZ;
    cbData := 0;

    if (RegQueryValueEx(hReg, pchar(szTypeString[WinNT]), nil,
      @lpType, nil, @cbData) = ERROR_SUCCESS) and (cbData > 0) then
    begin
      SetLength(sDriveType, cbData);
      if (RegQueryValueEx(hReg, pchar(szTypeString[WinNT]), nil,
        @lpType, @sDriveType[1], @cbData) = ERROR_SUCCESS) then
        SetLength(sDriveType, cbData - 1)
      else
        sDriveType := '';

      if (pos('DISK', uppercase(sDriveType)) = 1) then
        sDriveType := 'Festplatte'
      else if (pos('CDROM', uppercase(sDriveType)) = 1) then
        sDriveType := 'CD-ROM'
      else if (pos('Tape', uppercase(sDriveType)) = 1) then
        sDriveType := 'Bandlaufwerk';
    end;

    ZeroMemory(@szBuffer, sizeof(szBuffer));
    lpType := REG_SZ;
    cbData := 0;

    if (RegQueryValueEx(hReg, pchar(szIdString[WinNT]), nil,
      @lpType, nil, @cbData) = ERROR_SUCCESS) and (cbData > 0) then
      RegQueryValueEx(hReg, pchar(szIdString[WinNT]), nil,
        @lpType, @szBuffer, @cbData);
  finally
    RegCloseKey(hReg);
  end;

  if (lstrlen(szBuffer) > 0) then
    Result := Format('%s (%s)' + #13#10, [TrimSpaces(szBuffer), sDriveType])
  else
    Result := '';
end;

// Beispiel :
procedure TForm1.Button1Click(Sender: TObject);
var
  wv: TOSVersionInfo;
  scsiport: TScsiPorts;
  tid: TTargetIDArray;
  logU: TLogicalUnitIDs;
  v, u: string;
  h, i, j: integer;
begin
  wv.dwOSVersionInfoSize := sizeof(TOSVersionInfo);
  GetVersionEx(wv);
  WinNT := (wv.dwPlatformId = VER_PLATFORM_WIN32_NT);

  v := 'Prozessor:' + #13#10 +
    GetCPUFromReg() + ' (' + IntToStr(GetCPUSpeedFromReg()) + ' Mhz)';
  u := '';

  SetLength(scsiport, 0);
  SetLength(tid, 0);
  SetLength(logU, 0);

  scsiport := GetScsiPorts;
  if (length(scsiport) > 0) then
    for h := 0 to length(scsiport) - 1 do
    begin
      tid := GetTargetIDs(scsiport[h]);

      if (length(tid) > 0) then
        for i := 0 to length(tid) - 1 do
        begin
          logU := GetLogicalUnitIDs(tid[i]);

          if (length(logU) > 0) then
            for j := 0 to length(logU) - 1 do
              u := u + GetDrivesFromReg(logU[j]);
        end;
    end;

  SetLength(logU, 0);
  SetLength(tid, 0);
  SetLength(scsiport, 0);

  if (u <> '') then
    u := #13#10#13#10 + 'Laufwerke:' + #13#10 + u;

  // Ich habe bemerkt, dass bei der Benutzung von "@(v+u)[1]"
  // die MessageBox manchmal gar nicht angezeigt wird, wenn
  // der String leer war. Das war noch bei den Tests der alten
  // Version, die ja unter 98 keine Ergebnisse hatte.
  // Darum habe ich es so gemacht: mit "pchar(...)", meine ich!

  Messagebox(0, pchar(v + u), pchar(APPNAME + ' - ' + VER), MB_ICONINFORMATION);
end;
hackbard

Get CPU & Disk Information

Keine Kommentare:

Kommentar veröffentlichen

Beliebte Posts

Translate
