Private
Declare
FUNCTION
GetVolumeInformation
&
Lib
"
Kernel32
"
Alias
"
GetVolumeInformationa
"
(Byval LPROOTPATHNAME
AS
String
, ByVal PvoluMenameBuffer
AS
String
, ByVal NVolumenameSize
AS
Long
, Lpvolumeserialnumber
AS
Long
, LPMaximumComponentlength
AS
Long
, Lpfilesystemflags
AS
Long
, Byval lpfilesystemnamebuffer
AS
String
, ByVal NFileSystemNameSize
AS
Long
)
Private
Const
Max_filename_len
=
256
Private
Const
GetSerialPassword
=
"
LXY
"
Public
FUNCTION
Driveserial (Byval SDRV)
AS
String
)
AS
Long
'
Get the serial number of the hard disk
DIM
RetVal
AS
Long
DIM
Str
AS
String
*
Max_filename_len
DIM
STR2
AS
String
*
Max_filename_len
DIM
a
AS
Long
DIM
b
AS
Long
Call
GetVolumeInformation (SDRV
&
"
:
"
, STR, MAX_FILENAME_LEN, RETVAL, A, B, STR2, MAX_FILENAME_LEN DRIVESERIAL
=
RetVal
END FUNCTION
Public
FUNCTION
GetApplySerial ()
AS
Long
'
Generate an application code according to the serial number of the C drive
GetApplySerial
=
Driveserial
"
c
"
)
IF
GetApplySerial
<
0
THEN
GetApplySerial
=
0
-
GetApplySerial
END FUNCTION
'
Get serial numbers according to the application code and password table and password
Public
FUNCTION
GetSerial (Byval SRC)
AS
Long
, ByVal Password
AS
String
)
AS
String
DIM
SourceString
AS
String
DIM
Newsrc
AS
Long
For
I
=
0
TO
30
IF
(SRC
And
2
^
I)
=
2
^
I
THEN
SourceString
=
SourceString
"
1
"
Else
SourceString
=
SourceString
"
0
"
End
IF
NEXT
I
IF
SRC
<
0
THEN
SourceString
=
SourceString
"
1
"
Else
SourceString
=
SourceString
"
0
"
End
IF
DIM
TABLE
AS
String
'
============================================================================================================================================================================================================= ==========================
Parameter table is a password table, replaced according to your requirements, but the length should be consistent
'
============================================================================================================================================================================================================= =========================
'
Note: After the cryptographic table here, the corresponding registration number generator's password table must be completely consistent to generate the correct registration number.
TABLE
=
"
JSDJFKLUWRUOISDH; KSADJKLWQ; Abcdefhihl; Kladsdkjagfwiherqowrlqh
"
'
============================================================================================================================================================================================================= =========================
DIM
TableIndex
AS
Integer
DIM
Result
AS
String
DIM
Midword
AS
String
DIM
MidWordValue
AS
Byte
DIM
ResultValue
AS
Byte
For
t
=
1
TO
1
For
I
=
1
TO
Len
(SourceString) Midword
=
MID
(SourceString, I,
1
) MidWordValue
=
ASC
(MIDWORD) TABLEINDEX
=
TableIndex
1
IF
TableIndex
>
Len
(Table)
THEN
TableIndex
=
1
ResultValue
=
ASC
(
MID
(Table, TableIndex,
1
))
MOD
MidWordValue Result
=
Result
HEX
(ResultValue)
NEXT
I SourceString
=
Result
NEXT
t
DIM
BitTorool
AS
Integer
For
t
=
1
TO
Len
(
CSTR
(Src)) BitTorool
=
SRC
And
2
^
t
For
I
=
1
TO
BitTorool SourceString
=
Right
SourceString,
1
)
Left
SourceString,
Len
(SourceString)
-
1
)
NEXT
I
NEXT
t
IF
Password
=
GetSerialPassword
THEN
GetSerial
=
SourceString
Else
GetSerial
=
"
You have no right to get the software serial number
"
End
IF
END FUNCTION
'
Verify that the serial number is correct
Public
FUNCTION
ISserial (byval serial)
AS
String
)
AS
Boolean
IF
Serial
=
GetSerial (GetApplySerial (), GetSerialPassword
THEN
ISrial
=
True
Else
ISrial
=
False
End
IF
END FUNCTION
Public
FUNCTION
Checkserial ()
DIM
Ii
AS
New
INI II.FileName
=
"
D: akjfmanageserial.ini
"
'
INI file name
II.Appname
=
"
Serial
"
'
INI section name
II.Keyname
=
"
Serial
"
'
INI project name
Serial
=
Ii.Getini
IF
ISSERIAL (SERIAL)
THEN
Checkserial
=
"
Check by registration code
"
Else
Checkserial
=
"
Didn't pass the registration code, set the registration code in the serial.ini file
"
II.Keyname
=
"
ApplySerial
"
'
INI project name
Ii.valueStr
=
GetApplySerial () II.Writeini
End
IF
Set
Ii
=
Nothing
END FUNCTION
Author: heraldboy
