Encript Module

unit Media;

interface
uses WinTypes, WinProcs, Sysutils;

const
VWIN32_DIOC_DOS_IOCTL = 1;
word1:string = 'Reko';
word2:string = 'Srowako';

Type
{$IFNDEF WIN32}DWORD = Longint;{$ENDIF}
PMID = ^TMID;
TMID = packed record
InfoLevel: WORD;
SerialNumber: DWORD;
VolLabel: array[0..10] of char;
FSType: array[0..7] of char;
end;

Function HDSN(drive: char):DWORD;
Function Vol(drive: char):string;
Function FSType(drive: char):string;
Function InstallID(SN: DWORD):string;
Function SN(IID:string):string;
Function SN2HDSN(SN:string):DWORD;

implementation

Type
{$IFDEF WIN32}
PDevIOCtrlReg = ^TDevIOCtrlReg;
TDevIOCtrlReg = record
EBX: DWORD;
EDX: DWORD;
ECX: DWORD;
EAX: DWORD;
EDI: DWORD;
ESI: DWORD;
Flag: DWORD;
end;
{$ELSE}
DPMIRegisters =
record
DI : LongInt;
SI : LongInt;
BP : LongInt;
Reserved : LongInt;
BX : LongInt;
DX : LongInt;
CX : LongInt;
AX : LongInt;
Flags : Word;
ES : Word;
DS : Word;
FS : Word;
GS : Word;
IP : Word;
CS : Word;
SP : Word;
SS : Word;
end;
{$ENDIF}

Function GetMediaID(var MID: TMID; Drive: char):boolean; forward;

{$IFDEF WIN32}
function DoIOCTL(preg: PDevIOCtrlReg):boolean;
var
HDevice: THandle;
cb: DWORD;
fresult: boolean;
begin
preg^.Flag := $8000;
hDevice := CreateFile('\\.\vwin32', GENERIC_READ,
FILE_SHARE_READ or FILE_SHARE_WRITE,
Nil, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0);

if (HDevice = INVALID_HANDLE_VALUE) then
begin
result := false;
exit;
end
else
begin
fResult := DeviceIoControl(hDevice, VWIN32_DIOC_DOS_IOCTL,
preg, sizeof(preg^), preg, sizeof(preg^), cb, Nil);
if (not fResult) then
begin
result := false;
exit;
end;
end;
closeHandle(hDevice);
result := True;
end;

{$ELSE}
function RealIntr(IntNo : Byte; var Regs : DPMIRegisters) : Word; Assembler;
asm
xor bx,bx
mov bl,IntNo
xor cx,cx {StackWords = 0}
les di,Regs
mov ax,0300h
int 31h
jc @@ExitPoint
xor ax,ax
@@ExitPoint:
end;
{$ENDIF}

function HexToInt(Hex: String):dword;
var
x: word;
y: byte;
i, shift: integer;
c: char;
begin
x := 0;
Shift := 0;
for i := Length(Hex)-1 downto 0 do
begin
c := hex[i+1];
case c of
'0'..'9': y := ord(c)-ord('0');
'A'..'F', 'a'..'f': y := ord(c)-ord('A')+10
else y := 0;
end;
x := x + (y shl shift);
inc(shift, 4);
end;
result := x;
end;

Function HDSN(drive: char):DWORD;
var
MID: TMID;
begin
if GetMediaID(MID, drive) then
result := MID.SerialNumber
else
result := 0;
end;

Function Vol(drive: char):string;
var
MID: TMID;
begin
if GetMediaID(MID, drive) then
{$IFDEF WIN32}
result := String(MID.VolLabel);
{$ELSE}
result := StrPas(MID.VolLabel);
{$ENDIF}
end;

Function FSType(drive: char):string;
var
MID: TMID;
begin
if GetMediaID(MID, drive) then
{$IFDEF WIN32}
result := String(MID.FSType);
{$ELSE}
result := StrPas(MID.FSType);
{$ENDIF}
end;

Function InstallID(SN: DWORD):string;
var
xsn: array[1..7] of byte;
x: array[1..4] of word;
i: integer;
begin
move(SN, xsn, 4);
for i := 1 to 3 do xsn[8-1] := xsn[i];
for i := 1 to 7 do
xsn[i] := xsn[i] xor ord(word1[i]);

x[2] := 0;
move(xsn[1], x[1], 2);
move(xsn[3], x[2], 1);
move(xsn[4], x[3], 2);
move(xsn[6], x[4], 2);
result := format('%s-%s-%s-%s',
[inttohex(x[1], 4), inttohex(x[2], 2), inttohex(x[3], 4), inttohex(x[4], 4)]);
end;

Function SN(IID:string):string;
var
xsn: array[1..7] of byte;
x: array[1..4] of word;
i: integer;
s: String;
w: word;
begin
s := copy(IID, 1, 4); w := HexToInt(s); move(w, xsn[1], 2);
s := copy(IID, 6, 2); w := HexToInt(s); move(w, xsn[3], 1);
s := copy(IID, 9, 4); w := HexToInt(s); move(w, xsn[4], 2);
s := copy(IID, 14, 4); w := HexToInt(s); move(w, xsn[6], 2);

for i := 1 to 7 do
xsn[i] := xsn[i] xor ord(word2[i]);

x[2] := 0;
move(xsn[1], x[1], 2);
move(xsn[3], x[2], 1);
move(xsn[4], x[3], 2);
move(xsn[6], x[4], 2);
result := format('%s-%s-%s-%s',
[inttohex(x[1], 4), inttohex(x[2], 2), inttohex(x[3], 4), inttohex(x[4], 4)]);
end;

Function SN2HDSN(SN:string):DWORD;
var
xsn: array[1..7] of byte;
i: integer;
s: string;
w: word;
begin
s := copy(SN, 1, 4); w := HexToInt(s); move(w, xsn[1], 2);
s := copy(SN, 6, 2); w := HexToInt(s); move(w, xsn[3], 1);
s := copy(SN, 9, 4); w := HexToInt(s); move(w, xsn[4], 2);
s := copy(SN, 14, 4); w := HexToInt(s); move(w, xsn[6], 2);

for i := 1 to 7 do
xsn[i] := xsn[i] xor ord(word2[i]);

for i := 1 to 7 do
xsn[i] := xsn[i] xor ord(word1[i]);

move(xsn, result, 4);
end;

{$IFDEF WIN32}
function GetMediaID;
var
reg: TDevIOCtrlReg;
begin
reg.EAX := $440D;
reg.EBX := ord(UpCase(drive))-ord('A')+1;
reg.ECX := $0866;
reg.EDX := DWORD(@MID);

if (not DoIOCTL(@reg)) or ((reg.Flag and $8000)>0) then
result := false
else
result := true;
end;
{$ELSE}
function GetMediaID;
type
tLong = Record
LoWord, HiWord : Word;
End;
var
Regs : DPMIRegisters;
dwAddress : LongInt;
Address : tLong absolute dwAddress;
begin
Result := False;
FillChar(MID, SizeOf(MID), 0);
dwAddress := GlobalDosAlloc(SizeOf(MID)); { two paragraphs of DOS memory }
if dwAddress = 0
then { address is zero if error occurred }
exit;

With Regs do
begin
bx := ord(UpCase(drive))-ord('A')+1;
cx := $66;
ds := Address.HiWord;
ax := $6900;
dx := 0;
es := 0;
flags := 0;
end;
If RealIntr($21, Regs) <> 0
Then
Exit;
Move(ptr(Address.LoWord, 0)^, MID, SizeOf(MID));
GlobalDosFree(Address.LoWord); { free DOS memory block }
Result := True;
end;
{$ENDIF}

end.

Posted in: Delphi,Programming