Уважаемые авторы вопросов! Большая просьба сообщить о результатах решения проблемы на этой странице. Иначе, следящие за обсуждением, возможно имеющие аналогичные проблемы, не получают ясного представления об их решении. А авторы ответов не получают обратной связи. Что можно расценивать, как проявление неуважения к отвечающим от автора вопроса.
25-08-2006 20:51 | Комментарий к предыдущим ответам
Извините, ошибка вышла - старую версию функции выдал.
Должно быть так:
function OSVersion:string;
var vi:tOSVersionInfo;
begin
vi.dwOSVersionInfoSize:=sizeOf(tOSVersionInfo);
if getVersionEx(vi)then
with vi do
case dwPlatformId of
VER_PLATFORM_WIN32_WINDOWS:
if dwMinorVersion=0 then
result:='Windows 95' else result:='Windows 98';
VER_PLATFORM_WIN32_NT:result:='Windows NT\2000\XP';
VER_PLATFORM_WIN32s:result:='Win 3.1 with Win32s'
else result:='';
end;
end;
function BIOSDate:string;
var p:pointer;s:string[255];
begin
if OSVersion='Windows NT\2000\XP' then
begin
with tRegistry.Create do
try rootKey:=HKEY_LOCAL_MACHINE;
if openKeyReadOnly('HARDWARE\DESCRIPTION\System')then
result:=readString('systemBiosDate')
finally free;
end;
end else
try
s[0]:=#8;
p:=pointer($0FFFF5);
Move(p^,s[1],8);
result:=copy(s,1,2)+'/'+copy(s,4,2)+'/'+copy(s,7,2);
except result:='';
end;
end
;
Вот ещё кое-что (имя и изготовитель процессора):
function procName:string;
begin
if OSVersion='Windows NT\2000\XP' then
with tRegistry.Create do
try rootKey:=HKEY_LOCAL_MACHINE;
if openKeyReadOnly
('HARDWARE\DESCRIPTION\System\CentralProcessor\0')then
result:=readString('processorNameString')
finally free;
end;
end;
function procVendor:string;
begin
if OSVersion='Windows NT\2000\XP' then
with tRegistry.Create do
try rootKey:=HKEY_LOCAL_MACHINE;
if openKeyReadOnly
('HARDWARE\DESCRIPTION\System\CentralProcessor\0')then
result:=readString('VendorIdentifier')
finally free;
end;
end;
25-08-2006 08:40 | Комментарий к предыдущим ответам
Вот две функции, я ими часто пользуюсь.
Уж и не знаю где вы их используете, но под NT/W2K/XP это (вторая функция) работать не будет. А чтобы работало надо открывать устройство "\device\physicalmemory" или брать эту информацию из реестра (точную ветку не помню).
Вот две функции, я ими часто пользуюсь. Из модулей требуют только Windows.
function procType:string;
var
si:tSystemInfo;
begin
getSystemInfo(si);
result:='x'+intStr(si.dwProcessorType);
end;
function BIOSDate:string;
var
p:pointer;s:string[255];
begin
try
s[0]:=#8;
p:=pointer($0FFFF5);
move(p^,s[1],8);
result:=copy(s,1,2)+'/'+copy(s,4,2)+'/'+copy(s,7,2);
except
result:='';
end;
end;
привет
вот что я нарыл, кроме GetVolumeInformation:
(сам еще не проверял)
--------
нужно воспользоватся прямым обращением к устройству
\\.\PhysicalDrive0...4
функция ID
IDE_ID_FUNCTION = $EC; // Returns ID sector for ATA.
получиш сектор идентификации
там и серийник и фирма производитель и много чего еще
----------
Vladimir
{> Cut here. FileName= HDD_NUM.PAS }
{$IFDEF Windows}
uses WinCrt;
{$ENDIF}
var
InfoArray : array[0..255] of word;
IdeInfo : record
Config : word;
CylsTotal : word;
Unused : word;
HeadTotal : word;
BPT : word;
BPS : word;
SPT : word;
Vendor : array[0..2] of word;
Serial : array[1..20] of char;
BufType : Word;
BufSize : Word;
ECC : Word;
Revision : array[1..8] of char;
Model : array[1..40] of char;
end absolute InfoArray;
Count : byte;
i : byte;
begin
writeln('Информация о дисководах IDE:'^M^J);
{$IFDEF WINDOWS}
for count := 1 to mem[ $0040:$0075] do begin
{$ELSE}
for count := 1 to mem[Seg0040:$0075] do begin
{$ENDIF}
FillChar(InfoArray, SizeOf(InfoArray), 0);
{Проверить готовность}
while (port[$1F7] and $80<>0) do ;
{Запретить прерывания}
port[$3f6] := 2;
port[$1f6] := $A0 + ((count-1) shl 4);
port[$1f7] := $EC;
{Проверить готовность}
while (port[$1F7] and $80<>0) do ;
{Получить информацию}
for i := 0 to 255 do InfoArray[i] := swap(portw[$1F0]);
{Hапечатaть информацию}
writeln('Информация о физическом диске ',count-1,^M^J);
with IdeInfo do begin
writeln('Емкость неформатированная :', 9.5367431641E-7* {1/2^20}
swap(BPT)*swap(CylsTotal)*swap(HeadTotal):5:0, 'Mb');
writeln('Емкость форматированная :',
longint(swap(SPT))*swap(CylsTotal)*swap(HeadTotal) div 2048:5, 'Mb');
writeln('Число цилиндров :', swap(CylsTotal):7);
writeln('Число головок :', swap(HeadTotal):7);
writeln('Число секторов на дорожку :', swap(SPT):7);
writeln('Число байт на дорожку* :', swap(BPT):7);
writeln('Число байт на сектор* :', swap(BPS):7);
writeln('Размер буфера :', swap(BufSize):7);
writeln('Код ECC :', swap(ECC):7);
writeln(' * -- неформатированная емкость', ^M^J);
writeln('Серийный номер :', serial);
writeln('Версия :',revision);
writeln('Модель :',model);
end;
write('Hажмите любую клавишу...');
{$IFDEF WINDOWS}
readkey;
{$ELSE}
asm xor ah,ah ; int 16h end;
{$ENDIF}
writeln(^M^J);
end;
end.
------------
Про дату BIOS - под NT см qw 286
А вот так можно "по-человечески" считать Дату BIOS из реестра под 95.98
procedure TForm1.Button1Click(Sender: TObject);
const
key : String = '\Enum\Root\';
var
R : TRegistry;
S : TStringlist;
I : Word;
SubKey : String;
L : String;
begin
R := TRegistry.Create;
S := TStringList.Create;
with R do
begin
RootKey:=HKEY_LOCAL_MACHINE;
OpenKey(Key,False);
if HasSubkeys then
begin
GetKeyNames(S);
for i := 0 to S.Count-1 do
begin
SubKey:=Key+S.Strings[i]+'\0000';
OpenKey(SubKey,false);
L:=ReadString('BIOSVersion');
if L'' then Memo1.Lines.Append('BIOS Version '+L);
L:=ReadString('BIOSName');
if L'' then Memo1.Lines.Append('BIOS Name '+L);
L:=ReadString('BIOSDate');
if L'' then Memo1.Lines.Append('BIOS Date '+L);
end;
end;
end;
R.Free;
S.Free;
end;
{'>"Aziz" }
---------------
Этот метод работает под 95/98/Me/NT/2000/XP, а также работает (в отличие от распространенного метода получения mac-адреса через NetBIOS), если компьютер реально не подключен к сети.
Исправлена неточность в описании структуры IP_ADAPTER_INFO.
Спасибо {Alekos Sotiropulos}
type
//------IP address structures---------------------------------------------------
PIP_ADDRESS_STRING = ^IP_ADDRESS_STRING;
IP_ADDRESS_STRING = array[0..15] of char; // IP as string
function GetAdaptersInfo(pAdapterInfo: PIP_ADAPTER_INFO;
pOutBufLen: PULONG): DWORD; stdcall;
external 'Iphlpapi.dll' name 'GetAdaptersInfo';
const
OutBufLen: ULONG = 2000;
AddrLen = 6;
var
AdapterInfo: IP_ADAPTER_INFO;
Result: DWORD;
i: integer;
Next: PIP_ADAPTER_INFO;
begin
writeln;
writeln('-----------------------------');
writeln('Network adapter Info');
writeln('-----------------------------');
Result:= GetAdaptersInfo(@AdapterInfo, @OutBufLen);
if Result = 0 then
begin
Next:= @AdapterInfo;
repeat
writeln('Description: ', Next^.Description);
write('MAC address: ');
for i := 0 to AddrLen do
begin
write(IntToHex(Next^.Address[i], 2));
if i <> AddrLen then write('-');
end;
Next:= AdapterInfo.Next; // переходим к следующему адаптеру
writeln; writeln;
until Next = nil;
end
else writeln('Error. Result code: ', Result);
write('Press <Enter> to continue...');
readln;
end.
Кстати. По идее уникальность мак адреса сетевой карты должна гарантироваться производителем. Однако, недавно на работе попалось два компа со встроенными сетевухами и одинаковым мак адресом. Так что и винты, вероятно, могут такие найтись.
Проще всего действительно Serial винта прочитать.
Вот тут есть исходник: http://www.delphikingdom.com/asp/answer.asp?IDAnswer=22629
А вообще если это для защиты, то это очень неудобно с точки зрения пользователя: захотел я винчестер поменять и что мне делать? Лично я программами с такой защитой не пользуюсь и другим не советую.
Если вы заметили орфографическую ошибку на этой странице, просто выделите ошибку мышью и нажмите Ctrl+Enter. Функция может не работать в некоторых версиях броузеров.
