Fórum Serial do HD Unit Full #206241

Unit HardDisk;

INTERFACE

FUNCTION GetHardDiskNaam : STRING;
FUNCTION GetHardDiskSerieNummer : STRING;
FUNCTION GetHardDiskControlleNummer : STRING;
PROCEDURE GetHardDiskGegevens;

CONST
CodeerTabel : ARRAY[0..24] OF BYTE =
(3,1,2,1,4,1,3,2,6,4,6,5,1,2,6,4,2,6,3,4,6,2,4,1,2);

TYPE
CharArray = ARRAY[0..24] OF CHAR;

VAR
HardDiskGegevens : ARRAY[1..256] OF INTEGER;
HardDiskNaam : CharArray;
SerieNummer : CharArray;
ControlleNummer : CharArray;
C_HardDiskNaam : STRING;
C_HardDiskSerieNummer : STRING;
C_HardDiskControlleNummer : STRING;
C_LicentieNaam : STRING;

IMPLEMENTATION

FUNCTION GetHardDiskNaam : STRING;
VAR
Teller : INTEGER;
Lus : INTEGER;
BEGIN
GetHardDiskNaam := ´´;
Teller := 1;
FOR Lus := 1 TO 18 DO
BEGIN
HardDiskNaam[Teller] := CHR( ( HardDiskGegevens[27+Lus] DIV 256 ));
Inc(Teller);
HardDiskNaam[Teller] := CHR( ( HardDiskGegevens[27+Lus] MOD 256 ));
Inc(Teller);
END;
GetHardDiskNaam := HardDiskNaam;
END;

FUNCTION GetHardDiskSerieNummer : STRING;
VAR
Teller : INTEGER;
Lus : INTEGER;
BEGIN
GetHardDiskSerieNummer := ´´;
Teller := 1;
FOR Lus := 1 TO 8 DO
BEGIN
SerieNummer[Teller] := CHR( ( HardDiskGegevens[10+Lus] DIV 256 ));
Inc(Teller);
SerieNummer[Teller] := CHR( ( HardDiskGegevens[10+Lus] MOD 256 ));
Inc(Teller);
END;
GetHardDiskSerieNummer := SerieNummer;
END;

FUNCTION GetHardDiskControlleNummer : STRING;
VAR
Teller : INTEGER;
Lus : INTEGER;
BEGIN
GetHardDiskControlleNummer := ´´;
Teller := 1;
FOR Lus := 1 TO 3 DO
BEGIN
ControlleNummer[Teller] := CHR( ( HardDiskGegevens[23+Lus] DIV 256 ));
Inc(Teller);
ControlleNummer[Teller] := CHR( ( HardDiskGegevens[23+Lus] MOD 256 ));
Inc(Teller);
END;
GetHardDiskControlleNummer := ControlleNummer;
END;

PROCEDURE GetHardDiskGegevens;
VAR
Lus : INTEGER;
BEGIN
WHILE ( Port[$1f7] <> $50) DO ;
Port[$1F6] := $A0 ;
Port[$1F7] := $EC ;
WHILE ( Port[$1f7] <> $58 ) DO ;
FOR Lus := 1 TO 256 DO
BEGIN
HardDiskGegevens[Lus] := Portw[$1F0] ;
END;
END;

END.


A:
unit Chiunit4;

interface

function Chk...(ParamIn ... ,=20
ParamDatabaseNamePchar: pchar ): longint; export;

implementation

uses SysUtils, DBTables, ExtCtrls ;

const
ide_drive_C =3D $00A0;
ide_Data =3D $1F0;
ide_Error =3D $1F1;
ide_DriveAndHead =3D $1F6;
ide_Command =3D $1F7;
ide_command_readpar =3D $EC;
ide_Status =3D $1F7;
ide_status_busy =3D $80;
ide_status_ready =3D $40;
ide_status_error =3D $01;
ide_Fixed =3D $3F6;
ide_Fixed_Irq =3D $02;

IntervalleMinimum =3D 0.0000232;
{ 0.000011574 =3D 1 seconde (.0001 (hh.mmss) (->DEG=3D.0002777) / 24) }
{ .0000174 =3D 1 1/2 sec } { .0000232 =3D 2 sec }

type
tIdeRec =3D Record
rec : array[0..255] of word;
end;

var
ExitSave : Pointer;
IdeRec : tIdeRec;

function ConvertToString : string;
var
i,j : integer;
begin
FillChar( Result, 20, ´ ´ ); Result[0] :=3D #20;
for i :=3D 1 to 20 do
begin
j :=3D Trunc( (i-1) /2 ) +10 ;
if Lo(IdeRec.Rec[j]) =3D (0)
then Result[i]:=3D ´ ´
else
Result[i]:=3D Chr ( Lo( IdeRec.Rec[j] ) ) ;
i :=3D i +1;
if Hi(IdeRec.Rec[j]) =3D (0)
then Result[i]:=3D ´ ´
else
Result[i]:=3D Chr ( Hi( IdeRec.Rec[j] ) ) ;
end;
end;

function DoIt(Numero: string) : longint;
var
portchar :byte;
boo :Boolean;
i :integer;
S,S1 :String;
begin
Result:=3D 19 ; { fail per default }
FillChar( IdeRec.Rec, 512, ´ ´ ) ;

{ en premier lieu v=E9rifier l´=E9tat }
boo :=3D true;
{ poll DRQ wait }
i :=3D 5000 ;
repeat
i :=3D i -1;
portchar :=3D Lo(port[ide_status]) ; { get status }
until
( i < 1 ) or not
( ( portchar AND ide_status_busy ) =3D ide_status_busy ) ;
if i < 1 then
begin
{ Result:=3D ´status allways busy´; }
Result :=3D 180 ;
boo :=3D false;
end;

if boo then
try
{ premi=E8rement disable drive interrupts }
port[ide_Fixed] :=3D 0;

port[ide_DriveAndHead] :=3D ide_drive_C ; { set drive }
portchar :=3D Lo(port[ide_status]) ; { get status }
if portchar =3D $ff then begin
{ Result:=3D ´set drive status $ff´; }
Result :=3D 11 ;
boo :=3D false;
end;

if boo then
begin
{ poll DRQ wait }
i :=3D 1024 ;
repeat
i :=3D i -1;
portchar :=3D Lo(port[ide_status]) ;
until
( i < 1 ) or not
( ( portchar AND ide_status_busy ) =3D ide_status_busy ) ;
if i < 1 then
begin
{ Result:=3D ´status allways busy´; }
Result :=3D 181 ;
boo :=3D false;
end;
end;

if boo then
{ check if ready }
if ( portchar AND ide_status_ready ) =3D 0
then begin
{ Result:=3D ´set drive status not ready´; }
Result :=3D 12 ;
boo :=3D false;
end;

if boo then
{ ok now want to readIDE }
{ send ReadParameters command }
port[ide_Command] :=3D ide_command_readpar ;

{ poll DRQ wait }
i :=3D 5000 ;
repeat
i :=3D i -1;
portchar :=3D Lo(port[ide_status]) ;
until
( i < 1 ) or not
( ( portchar AND ide_status_busy ) =3D ide_status_busy ) ;
if i < 1 then
begin
{ Result:=3D ´status allways busy´; }
Result :=3D 182 ;
boo :=3D false;
end;

if boo then
{ check if no error}
if ( portchar AND ide_status_error ) =3D ide_status_error
then begin
{ Result:=3D ´drive status error after ReadPar´; }
Result :=3D 13 ;
boo :=3D false;
end;

if boo then
{ check if ready }
if ( portchar AND ide_status_ready ) =3D 0
then begin
{ Result:=3D ´after ReadPar drive status not ready´; }
Result :=3D 14 ;
boo :=3D false;
end;

if boo then
try
{ ok now read the buffer 256 word }
for i :=3D 0 to 255 do
begin
IdeRec.Rec[i] :=3D ( portw[ide_Data] ) ;
end;
except
on Exception do begin
{ ShowMessage( ´Erreur portw i=3D ´+intToStr(i)=
) ; }
boo :=3D false;
Result :=3D 15 ;
end;
else begin
boo :=3D false;
Result :=3D 16 ;
raise;
end;
end;

if boo Then
begin
S :=3D ConvertToString;
if length(Numero) < 20 then S1:=3D Numero +´ ´
else S1:=3D Numero;
if CompareStr ( S, Copy(S1,1,20) ) =3D 0
then Result :=3D 10
else Result :=3D 17 ;
{ Result :=3D ´(´+S+´)<>(´+Copy(S1,1,20)+´)´ ; }
end;
finally
{ re-enable disk interrupts }
port[ide_Fixed] :=3D ide_Fixed_Irq ;
end;
END;

procedure MyExit; far;
{ reset disk parameters so other disk operations won´t be desturbed in ca=
se
of program abort }
begin
ExitProc :=3D ExitSave; { restore previous exitproc }
{ Port[ide_Command]:=3D$10; { send command: reset current drive }
end;

function GetParam(ParamAlias: string): String;
var
i : integer ;
t : TTable ;
S : String ;
begin
Result :=3D ´´;
try
t :=3D nil;
t :=3D TTable.Create(nil);
t.DatabaseName :=3D ParamAlias;
t.TableName :=3D ...;
t.TableType :=3D ttPARADOX;
t.open;
...
finally
if Assigned(t) then t.free ;
end;
end;

function FixParam(ParamAlias: string): boolean;
var
i : integer ;
t : TTable ;
S : String ;
begin
Result :=3D False;
try
t :=3D nil;
t :=3D TTable.Create(nil);
t.DatabaseName :=3D ParamAlias;
t.TableName :=3D ;
t.TableType :=3D ttPARADOX;
t.open;
if=20
begin
... t.Edit;
t.setFields([nil, S]);
t.post;
end;
t.close;
Result :=3D True;
finally
if Assigned(t) then t.free ;
end;
end;

{----------------------------------------------------}

function Chk...(ParamIn: ;
ParamDatabaseNamePchar: pchar ): longInt ;
var
ParamString : String; =20
Temps : Real;
Ok : boolean;
i: integer;
S : string[20];
S6 : string[6];
r : longInt;

Label
Jump;
BEGIN
Result:=3D 0 ; { par d=E9faut }
if Ok then
i :=3D 0;
repeat
begin
i :=3D i +1 ;
r :=3D DoIt(Copy(ParamString,54,20)) ;
if r =3D 10 then begin
Ok :=3D True ;
break
end
else begin
Ok :=3D False ;
Result:=3D r;
Continue;
end;
end;
until i =3D 3 ;
If Ok
then begin
Ok :=3D FixParam(ParamDatabaseName) ;
If Ok then else { Result :=3D ´FixParam fail´; }
Result :=3D 2 ;
end;
If Ok then Result :=3D 1 ;
END;

Begin
ExitSave:=3D ExitProc;
ExitProc:=3D @MyExit;
end.