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 ' 得到硬盘的序列号
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 ' 根据c盘的序列号生成一个申请码
GetApplySerial = DriveSerial( " c " )
If GetApplySerial < 0 Then GetApplySerial = 0 - GetApplySerial
End Function
' 根据申请码和密码表及密码得到序列号
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
' ==========================================================================
' 参数Table是密码表,根据你的要求换成别的,不过长度要一致
' ==========================================================================
' 注意:这里的密码表变动后,对应的注册号生成器的密码表也要完全一致才能生成正确的注册号
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 = " 你无权获得软件序列号 "
End If
End Function
' 验证序列号是否正确
Public Function IsSerial(ByVal Serial As String ) As Boolean
If Serial = getSerial(GetApplySerial(), GETSERIALPASSWORD) Then
IsSerial = True
Else
IsSerial = False
End If
End Function
Public Function checkSerial()
Dim II As New INI
II.FileName = " D:akJFManageserial.ini " ' INI文件名
II.AppName = " SERIAL " ' INI小节名称
II.KeyName = " Serial " ' INI项目名
Serial = II.GetINI
If IsSerial(Serial) Then
checkSerial = " 通过注册码检查 "
Else
checkSerial = " 没通过注册码检查,请在serial.ini文件中设置注册码 "
II.KeyName = " ApplySerial " ' INI项目名
II.ValueStr = GetApplySerial()
II.WriteINI
End If
Set II = Nothing
End Function
Private Const MAX_FILENAME_LEN = 256
Private Const GETSERIALPASSWORD = " lxy "
Public Function DriveSerial(ByVal sDrv As String ) As Long ' 得到硬盘的序列号
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 ' 根据c盘的序列号生成一个申请码
GetApplySerial = DriveSerial( " c " )
If GetApplySerial < 0 Then GetApplySerial = 0 - GetApplySerial
End Function
' 根据申请码和密码表及密码得到序列号
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
' ==========================================================================
' 参数Table是密码表,根据你的要求换成别的,不过长度要一致
' ==========================================================================
' 注意:这里的密码表变动后,对应的注册号生成器的密码表也要完全一致才能生成正确的注册号
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 = " 你无权获得软件序列号 "
End If
End Function
' 验证序列号是否正确
Public Function IsSerial(ByVal Serial As String ) As Boolean
If Serial = getSerial(GetApplySerial(), GETSERIALPASSWORD) Then
IsSerial = True
Else
IsSerial = False
End If
End Function
Public Function checkSerial()
Dim II As New INI
II.FileName = " D:akJFManageserial.ini " ' INI文件名
II.AppName = " SERIAL " ' INI小节名称
II.KeyName = " Serial " ' INI项目名
Serial = II.GetINI
If IsSerial(Serial) Then
checkSerial = " 通过注册码检查 "
Else
checkSerial = " 没通过注册码检查,请在serial.ini文件中设置注册码 "
II.KeyName = " ApplySerial " ' INI项目名
II.ValueStr = GetApplySerial()
II.WriteINI
End If
Set II = Nothing
End Function
原作者:heraldboy