home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Power-Programmierung
/
CD1.mdf
/
magazine
/
pcmagazi
/
1992
/
13
/
serial.pas
< prev
next >
Wrap
Pascal/Delphi Source File
|
1991-10-14
|
3KB
|
127 lines
PROGRAM Serial;
CONST
HexDigits : ARRAY[0..15] OF Char = '0123456789ABCDEF';
TYPE
InfoBuffer = RECORD
InfoLevel : Word; {should be zero}
Serial : LongInt;
VolLabel : ARRAY[0..10] OF Char;
FileSystem : ARRAY[0..7] OF Char;
END;
SerString = String[9];
VAR
IB : InfoBuffer;
N : Word;
let : Char;
param : String[10];
IsSet : Boolean;
NewSerial : LongInt;
code : Integer;
FUNCTION SerialStr(L : LongInt) : SerString;
VAR Temp : SerString;
BEGIN
Temp[0] := #9;
Temp[1] := HexDigits[L SHR 28];
Temp[2] := HexDigits[(L SHR 24) AND $F];
Temp[3] := HexDigits[(L SHR 20) AND $F];
Temp[4] := HexDigits[(L SHR 16) AND $F];
Temp[5] := '-';
Temp[6] := HexDigits[(L SHR 12) AND $F];
Temp[7] := HexDigits[(L SHR 8) AND $F];
Temp[8] := HexDigits[(L SHR 4) AND $F];
Temp[9] := HexDigits[L AND $F];
SerialStr := Temp;
END;
FUNCTION GetSerial(DiskNum : Byte;
VAR I : InfoBuffer) : Word; Assembler;
ASM
MOV AH, 69h
MOV AL, 00h
MOV BL, DiskNum
PUSH DS
LDS DX, I
INT 21h
POP DS
JC @Bad
XOR AX, AX
@Bad:
END;
FUNCTION SetSerial(DiskNum : Byte;
VAR I : InfoBuffer) : Word; Assembler;
ASM
MOV AH, 69h
MOV AL, 01h
MOV BL, DiskNum
PUSH DS
LDS DX, I
INT 21h
POP DS
JC @Bad
XOR AX, AX
@Bad:
END;
PROCEDURE ErrorOut(err : Byte);
BEGIN
CASE err OF
5 : BEGIN
WriteLn('Either the disk in ',let,': is write-',
'protected or it lacks an extended BPB.');
WriteLn('If the disk is not write-protected, ',
'reformat with DOS 4 or higher.');
END;
15 : WriteLn('Not a valid drive letter.');
255 : BEGIN
WriteLn('SYNTAX: "Serial d: ########"');
WriteLn(' where d: is the drive letter ',
'and ######## is the eight-digit');
WriteLn(' hexadecimal serial number.');
WriteLn('EXAMPLE: "Serial 1234ABCD"');
END;
ELSE WriteLn('DOS ERROR #',N);
END;
Halt(1);
END;
BEGIN
IF ParamCount < 1 THEN ErrorOut(255);
IF ParamCount > 2 THEN ErrorOut(255);
Param := ParamStr(1);
CASE length(Param) OF
1 : ; {ok}
2 : IF Param[2] <> ':' THEN ErrorOut(255);
ELSE ErrorOut(255);
END;
Let := UpCase(Param[1]);
IF (Let < 'A') OR (Let > 'Z') THEN ErrorOut(15);
IF ParamCount < 2 THEN IsSet := FALSE
ELSE
BEGIN
IsSet := TRUE;
Param := '$'+ParamStr(2);
Val(Param, NewSerial, Code);
IF Code <> 0 THEN ErrorOut(255);
END;
N := GetSerial(Ord(Let)-Ord('@'), IB);
IF N = 0 THEN
BEGIN
WITH IB DO
BEGIN
WriteLn('Serial number is "', SerialStr(Serial),'"');
IF IsSet THEN
BEGIN
Serial := NewSerial;;
N := SetSerial(Ord(Let)-Ord('@'), IB);
IF N = 0 THEN
WriteLn('Successfully changed serial to "',
SerialStr(NewSerial),'"')
ELSE ErrorOut(N);
END;
END;
END
ELSE ErrorOut(N);
END.