{
ShowBiosData.dpr
Mostra os dados da BIOS do micro. Roda em Windows 9x/ME ou
NT/2000/XP/2003.
por Rubem Nascimento da Rocha - djpardalro...@hotmail.com
Pode ser usado livremente, desde que seja dado o devido crédito ao autor.
}
program ShowBiosData;
{$APPTYPE CONSOLE}
{$WARNINGS OFF}
uses
Windows, SysUtils, Classes, Types, Registry;
const
// Para uso somente em plataformas Windows 9x/ME
cBIOSName = $FE061;
cBIOSDate = $FFFF5;
cBIOSExtInfo = $FEC71;
cBIOSCopyright = $FE091;
// Para uso somente em plataformas NT (NT/2000/XP/2003/etc.)
rkBIOS = '\HARDWARE\DESCRIPTION\System';
rvBiosDate = 'SystemBiosDate';
rvBiosID = 'Identifier';
rvBiosVersion = 'SystemBiosVersion';
function MultiSzToArray(const MultiSz: PChar): TStringDynArray;
var
P: PChar; // aponta para as strings no buffer
begin
SetLength(Result, 0);
// Não faz nada se MultiSz é nil
if not Assigned(MultiSz) then
Exit;
// Busca por strings delimitadas por #0 até encontrar #0#0
P := MultiSz;
while P^ <> #0 do
begin
// adiciona strings ao vetor resultado (retorno da função)
SetLength(Result, Length(Result) + 1);
Result[Length(Result) - 1] := StrPas(P);
// move ponteiro para o início da próximo string (se houver)
Inc(P, StrLen(P) + 1);
end;
end;
procedure MultiStrFromBuf(Buffer: array of Byte; var List: TStringList);
var
p: PChar;
lStrings: TStringDynArray;
i: Integer;
begin
p := PChar(@Buffer);
lStrings := MultiSzToArray(p);
for i := Low(lStrings) to High(lStrings) do
List.Add(lStrings[i]);
end;
function ReadRegistryValueAsString(Root: HKEY; Key, Value: string;
BinaryAsHex: Boolean = True): string;
var
sl: TStringList;
i, DataSize, DataType: Integer;
Data: array[0..1024] of Byte;
begin
Result := EmptyStr;
with TRegistry.Create do
try
RootKey := Root;
Access := KEY_READ;
if OpenKey(Key, False) and ValueExists(Value) then
begin
RegQueryValueEx(CurrentKey, PChar(Value), nil, PDWORD(@DataType), nil,
PDWORD(@DataSize));
case DataType of
REG_SZ:
Result := ReadString(Value);
REG_EXPAND_SZ:
begin
Result := ReadString(Value);
DataSize := ExpandEnvironmentStrings(PChar(Result), nil,
DataSize);
if DataSize > 0 then
begin
DataSize :=
ExpandEnvironmentStrings(PChar(Result), PChar(@Data),
DataSize);
Result := string(PChar(@Data));
end;
end;
REG_DWORD, REG_DWORD_BIG_ENDIAN:
Result := IntToStr(ReadInteger(Value));
REG_MULTI_SZ:
begin
Result := EmptyStr;
if DataSize > -1 then
begin
ReadBinaryData(Value, Data, DataSize);
sl := TStringList.Create;
try
MultiStrFromBuf(Data, sl);
Result := sl.Text;
finally
sl.Free;
end;
end;
end;
else
begin
Result := EmptyStr;
if DataSize >- 1 then
begin
ReadBinaryData(Value, Data, DataSize);
if BinaryAsHex then
begin
i := 0;
if Data[i] <> 0 then
Result := Result + Format('%2.2x', [Data[i]])
else
if Copy(Result, Length(Result), 1) <> #10 then
Result := Result + sLineBreak;
SetLength(Result, Length(Result) - 2);
end
else
begin
for i := 0 to DataSize - 1 do
Result := Result + Format('%2.2x ',[Ord(Data[i])]);
SetLength(Result, Length(Result) - 1);
end;
end;
end;
end;
CloseKey;
end;
finally
Free;
end;
end;
function BIOSName: String;
begin
Result :=
ReadRegistryValueAsString(HKEY_LOCAL_MACHINE, rkBIOS, rvBiosID, False);
end;
function BIOSDate: String;
begin
Result :=
ReadRegistryValueAsString(HKEY_LOCAL_MACHINE, rkBIOS, rvBiosDate,
False);
end;
function BIOSCopyright: AnsiString;
begin
Result :=
ReadRegistryValueAsString(HKEY_LOCAL_MACHINE, rkBIOS, rvBiosVersion,
False);
end;
begin
if Win32Platform < VER_PLATFORM_WIN32_NT then
begin
WriteLn('BIOS Name: ', StrPas(PChar(Ptr(cBIOSName))));
WriteLn('BIOS Data: ', StrPas(PChar(Ptr(cBIOSDate))));
WriteLn('BIOS Copyright: ', StrPas(PChar(Ptr(cBIOSCopyright))));
WriteLn('BIOS Extended Info: ', StrPas(PChar(Ptr(cBIOSExtInfo))));
end
else
begin
WriteLn('BIOS Name: ', BIOSName);
WriteLn('BIOS Date: ', BIOSDate);
WriteLn('BIOS Copyright: ', BIOSCopyright);
end;
WriteLn(Eoln);
end.
Rubem Nascimento da Rocha
92 8429 2865
rubem.ro...@digitalti.com.br
assinatura email
Digital TI - Coordenação de Automação
Av. Carvalho Leal, 1330 - 1º Andar
Cachoeirinha - 69065-001 Manaus/AM
Call Center: 92 2101-0100
<http://www.dtmanaus.com.br> www.dtmanaus.com.br
[As partes desta mensagem que não continham texto foram removidas]
